var/da/da_setup_structures/da_setup_firstguess.inc

   1 subroutine da_setup_firstguess(xbx, grid, config_flags, ens )
   2
   3    !---------------------------------------------------------------------------
   4    ! Purpose: Allocate and read in components of first guess state.
   5    !    Updated for Analysis on Arakawa-C grid
   6    !    Author: Syed RH Rizvi,  MMM/ESSL/NCAR,  Date: 10/22/2008
   7    !---------------------------------------------------------------------------
   8
   9    implicit none
  10
  11    type (xbx_type),intent(out)  :: xbx   ! Header & non-gridded vars.
  12
  13    type(domain),intent(inout)   :: grid
  14    type(grid_config_rec_type), intent(in) :: config_flags
  15    logical, intent(in) :: ens
  16
  17    integer :: is, ie, js, je, ij, i, j
  18    real    :: ddx , ddy
  19
  20    if (trace_use) call da_trace_entry("da_setup_firstguess")
  21
  22    is = grid%xp % its
  23    ie = grid%xp % ite
  24    js = grid%xp % jts
  25    je = grid%xp % jte
  26
  27    ! Calculate sin and cosine values used in da_get_avpoles
  28
  29    if (global) then
  30       if (grid%xp%jts == grid%xp%jds) then
  31
  32          allocate(cos_xls(grid%xp%its:grid%xp%ite))
  33          allocate(sin_xls(grid%xp%its:grid%xp%ite))
  34          cos_xls(grid%xp%its:grid%xp%ite) = &
  35             cos(deg_to_rad*grid%xlong(grid%xp%its:grid%xp%ite,grid%xp%jts))
  36          sin_xls(grid%xp%its:grid%xp%ite) = &
  37             sin(deg_to_rad*grid%xlong(grid%xp%its:grid%xp%ite,grid%xp%jts))
  38       end if
  39
  40       if (grid%xp%jte == grid%xp%jde) then
  41          allocate(cos_xle(grid%xp%its:grid%xp%ite))
  42          allocate(sin_xle(grid%xp%its:grid%xp%ite))
  43          cos_xle(grid%xp%its:grid%xp%ite) = &
  44             cos(deg_to_rad*grid%xlong(grid%xp%its:grid%xp%ite,grid%xp%jte))
  45          sin_xle(grid%xp%its:grid%xp%ite) = &
  46             sin(deg_to_rad*grid%xlong(grid%xp%its:grid%xp%ite,grid%xp%jte))
  47       end if
  48    end if
  49
  50    !---------------------------------------------------------------------------
  51    ! [1.0] Setup and read in fields from first guess:
  52    !---------------------------------------------------------------------------
  53
  54    if ((fg_format==fg_format_wrf_arw_regional) .or. &
  55       (fg_format==fg_format_wrf_arw_global  ) ) then
  56       call da_setup_firstguess_wrf(xbx, grid, config_flags,ens)
  57       ! when ens=.true., da_setup_firstguess(_wrf) is called solely for map_info,
  58       ! the rest of the code should be skipped
  59       if ( ens ) then
  60          if (trace_use) call da_trace_exit("da_setup_firstguess")
  61          return
  62       end if
  63    else if (fg_format == fg_format_wrf_nmm_regional ) then
  64       call da_setup_firstguess_wrf_nmm_regional(xbx, grid)
  65    else if (fg_format == fg_format_kma_global) then
  66       ! First guess is an KMA format file:
  67       call da_setup_firstguess_kma(xbx, grid)
  68    end if
  69
  70    !---------------------------------------------------------------------------
  71    ! Exchange halo region for XB arrays.
  72    !---------------------------------------------------------------------------
  73
  74    if ((fg_format==fg_format_wrf_arw_regional) .or. &
  75       (fg_format==fg_format_wrf_arw_global  ) ) then
  76       ! Calculate multiplicative constants for PsiChi_TO_UV
  77       !$OMP PARALLEL DO &
  78       !$OMP PRIVATE (ij, i, j)
  79       do ij = 1, grid%num_tiles
  80          do j = grid%j_start(ij), grid%j_end(ij)
  81             do i = is, ie
  82                grid%xb%coefx(i,j) = 0.5 * grid%xb%map_factor(i,j)/grid%xb%ds
  83                grid%xb%coefy(i,j) = grid%xb%coefx(i,j)
  84                grid%xb%coefz(i,j) = 0.5 / (grid%xb%map_factor(i,j)*grid%xb%ds)
  85             end do
  86          end do
  87       end do
  88       !$OMP END PARALLEL DO
  89    else if (fg_format == fg_format_wrf_nmm_regional) then
  90       grid%xb%coefx(is:ie,js:je) = 0.5/grid%mu0(is:ie,js:je)
  91       grid%xb%coefy(is:ie,js:je) = 0.5/grid%xb%ds
  92    else if (fg_format == fg_format_kma_global) then
  93       ! Calculate multiplicative constants for PsiChi_TO_UV
  94       ddx =  earth_radius*1000 * 2.0 * pi / (grid%xb%ide-grid%xb%ids+1)
  95       ddy =  earth_radius*1000       * pi / (grid%xb%jde-grid%xb%jds)
  96       grid%xb% coefx(is:ie,js:je) = 0.5 / (ddx * cos(grid%xlat(is:ie,js:je)*pi/180.))
  97       grid%xb% coefy(is:ie,js:je) = 0.5 /  ddy
  98    else
  99       write(unit=message(1),fmt='(A,I5)') &
 100          "Wrong choice for fg_format = ",fg_format
 101       call da_error(__FILE__,__LINE__,message(1:1))
 102    end if
 103
 104 #ifdef A2C
 105   if ((fg_format==fg_format_wrf_arw_regional  .or. &
 106        fg_format==fg_format_wrf_arw_global  ) .and. ide == ipe ) then
 107      ipe = ipe + 1
 108      ide = ide + 1
 109   end if
 110
 111   if ((fg_format==fg_format_wrf_arw_regional  .or. &
 112        fg_format==fg_format_wrf_arw_global  ) .and. jde == jpe ) then
 113      jpe = jpe + 1
 114      jde = jde + 1
 115   end if
 116 #endif
 117 #ifdef DM_PARALLEL
 118 #include "HALO_INIT.inc"
 119 #if (WRF_CHEM == 1)
 120 #include "HALO_CHEM_INIT.inc"
 121 #endif
 122 #endif
 123
 124 #ifdef A2C
 125   if ((fg_format==fg_format_wrf_arw_regional  .or. &
 126        fg_format==fg_format_wrf_arw_global  ) .and. ide == ipe ) then
 127      ipe = ipe - 1
 128      ide = ide - 1
 129   end if
 130
 131   if ((fg_format==fg_format_wrf_arw_regional  .or. &
 132        fg_format==fg_format_wrf_arw_global  ) .and. jde == jpe ) then
 133      jpe = jpe - 1
 134      jde = jde - 1
 135   end if
 136 #endif
 137
 138    periodic_x = grid%periodic_x
 139
 140    if (global) then
 141       ! Set East-West boundary for Xb-array
 142       call da_set_boundary_xb(grid)
 143    end if
 144
 145    !---------------------------------------------------------------------------
 146    ! [2.0] Setup grid-dependent constants used:
 147    !---------------------------------------------------------------------------
 148
 149    ! [2.1] Set up fast Fourier & Legendre transform constants:
 150
 151    if (SIZE(xbx%fft_factors_x) /=num_fft_factors) &
 152       call da_setup_runconstants(grid, xbx)
 153
 154    if (trace_use) call da_trace_exit("da_setup_firstguess")
 155
 156 end subroutine da_setup_firstguess
 157
 158