var/da/da_vtox_transforms/da_calc_covariance.inc

   1 SUBROUTINE da_calc_covariance( xb, xbx, be, cv, vv, vp, xp, xa,        &
   2                                ids, ide, jds, jde, kds, kde,        &
   3                                ims, ime, jms, jme, kms, kme,        &
   4                                its, ite, jts, jte, kts, kte )
   5
   6 !------------------------------------------------------------------------------
   7 !  PURPOSE: Run pseudo-ob test to check approximation of B = UU^T by VToX
   8 !           transforms.
   9 !
  10 !  METHOD:  Test x = U U^T x_hat where x__hat is pseudo-ob.
  11 !
  12 !  HISTORY: 08/28/2000 - Creation of F90 version.           Dale Barker
  13 !
  14 !  PARENT_MODULE: DA_VToX_Transforms
  15 !------------------------------------------------------------------------------
  16
  17    IMPLICIT NONE
  18
  19    type (xb_type), intent(in)         :: xb     ! first guess (local).
  20    type (xbx_type),intent(in)         :: xbx    ! For header & non-grid arrays.
  21    type (be_type), intent(in)         :: be     ! background error structure.
  22    real,intent(inout),dimension(cv_size):: cv   ! control variable (local).
  23    type (vp_type), intent(inout)      :: vv     ! Grdipt/EOF CV.
  24    type (vp_type), intent(inout)      :: vp     ! Grdipt/level CV.
  25    type (xpose_type), intent(inout)   :: xp     ! Domain decomposition vars.
  26    type (x_type) , intent(inout)      :: xa     ! gridded analy. incs. (local)
  27    integer, intent(in)              :: ids,ide, jds,jde, kds,kde ! domain dims.
  28    integer, intent(in)              :: ims,ime, jms,jme, kms,kme ! memory dims.
  29    integer, intent(in)              :: its,ite, jts,jte, kts,kte ! tile   dims.
  30
  31    INTEGER                            :: i, j, k, ii, jj, kk! Location indicators.
  32    REAL, POINTER                      :: field(:,:,:)
  33
  34    WRITE(0,'(A)')  ' da_calc_covariance: Testing x = U U^T x_hat'
  35    WRITE(0,'(A,/)')' -------------------------------------------'
  36
  37    i = nint(pseudo_x)
  38    j = nint(pseudo_y)
  39    k = nint(pseudo_z)
  40
  41    IF ( pseudo_var(1:1) == 'u' .OR. pseudo_var(1:1) == 'U' ) THEN
  42       xa % u(i,j,k) = pseudo_val
  43    ELSE IF ( pseudo_var(1:1) == 'v' .OR. pseudo_var(1:1) == 'V') THEN
  44       xa % v(i,j,k) = pseudo_val
  45    ELSE IF ( pseudo_var(1:1) == 't' .OR. pseudo_var(1:1) == 'T') THEN
  46       xa % t(i,j,k) = pseudo_val
  47    ELSE IF ( pseudo_var(1:1) == 'p' .OR. pseudo_var(1:1) == 'P') THEN
  48       xa % p(i,j,k) = pseudo_val
  49    ELSE IF ( pseudo_var(1:1) == 'q' .OR. pseudo_var(1:1) == 'Q') THEN
  50       xa % q(i,j,k) = pseudo_val
  51    ELSE
  52       WRITE(0,'(A,A)')' Invalid pseudo_var = ', pseudo_var
  53    END IF
  54
  55    WRITE(0,'(A,A1)')' Model variable is ', pseudo_var
  56    WRITE(0,'(A,1pe8.2)')' Test increment value is ', pseudo_val
  57    WRITE(0,'(A,3I4)')' i, j, k location is ', i, j, k
  58
  59 !------------------------------------------------------------------------------
  60 !  [3.0] Calculate structure function:
  61 !------------------------------------------------------------------------------
  62
  63 !  [3.1] Calculate v_hat = U^T x_hat
  64    call da_zero_vp_type(vp)
  65    call da_transform_vtox_adj( xb, xbx, be, xa, xp, vp, vv, cv, &
  66                                ids, ide, jds, jde, kds, kde,           &
  67                                ims, ime, jms, jme, kms, kme,           &
  68                                its, ite, jts, jte, kts, kte )
  69
  70 !  [3.2] Calculate x = U v_hat
  71    call da_transform_vtox( xb, xbx, be, cv, vv, vp, xp, xa,        &
  72                            ids, ide, jds, jde, kds, kde,           &
  73                            ims, ime, jms, jme, kms, kme,           &
  74                            its, ite, jts, jte, kts, kte )
  75
  76 !------------------------------------------------------------------------------
  77 !  [5.0] Output results::
  78 !------------------------------------------------------------------------------
  79
  80    IF ( pseudo_var(1:1) == 'u' .OR. pseudo_var(1:1) == 'U' ) THEN
  81       field => xa % u(its:ite,jts:jte,kts:kte)
  82    ELSE IF ( pseudo_var(1:1) == 'v' .OR. pseudo_var(1:1) == 'V') THEN
  83       field => xa % v(its:ite,jts:jte,kts:kte)
  84    ELSE IF ( pseudo_var(1:1) == 't' .OR. pseudo_var(1:1) == 'T') THEN
  85       field => xa % t(its:ite,jts:jte,kts:kte)
  86    ELSE IF ( pseudo_var(1:1) == 'p' .OR. pseudo_var(1:1) == 'P') THEN
  87       field => xa % p(its:ite,jts:jte,kts:kte)
  88    ELSE IF ( pseudo_var(1:1) == 'q' .OR. pseudo_var(1:1) == 'Q') THEN
  89       field => xa % q(its:ite,jts:jte,kts:kte)
  90    END IF
  91
  92    WRITE(0,'(A,1pe12.5)')' Response at ob location  = ', field(i,j,k)
  93    WRITE(0,'(A,2e15.5)')' Min/Max response at ob level = ', &
  94                         MINVAL(field(its:ite,jts:jte,k)), &
  95                         MAXVAL(field(its:ite,jts:jte,k))
  96    WRITE(0,'(A,2e15.5)')' Min/Max response anywhere = ', &
  97                         MINVAL(field(its:ite,jts:jte,kts:kte)), &
  98                         MAXVAL(field(its:ite,jts:jte,kts:kte))
  99
 100    CALL DA_Array_Print(2, field(its:ite,jts:jte,k), 'field(its:ite,jts:jte,k)' )
 101
 102    do jj = jts, jte
 103       write(25,'(3i5,1pe15.5)')i, jj, k, field(i,jj,k)
 104    end do
 105
 106    do ii = its, ite
 107       write(25,'(3i5,1pe15.5)')ii, j, k, field(ii,j,k)
 108    end do
 109
 110    NULLIFY( field )
 111
 112    WRITE(0,'(A)')  ' da_calc_covariance finished. Stopping'
 113    WRITE(0,'(A,/)')' -------------------------------------'
 114
 115    STOP
 116
 117 END SUBROUTINE da_calc_covariance
 118