var/da/da_setup_structures/da_setup_obs_structures_bufr.inc

   1 subroutine da_setup_obs_structures_bufr(grid, ob, iv)
   2
   3    !---------------------------------------------------------------------------
   4    ! Purpose: Define, allocate and read observation structure.
   5    !---------------------------------------------------------------------------
   6
   7    implicit none
   8
   9    type (domain) , intent(in)    :: grid        ! model data
  10    type (y_type),  intent(out)   :: ob          ! Observation structure.
  11    type (iv_type), intent(inout) :: iv          ! O-B structure.
  12
  13 #ifdef BUFR
  14
  15    character(len=filename_len) :: filename
  16    integer                     :: n,i,j
  17    integer :: nplev
  18    logical :: has_errtable
  19    integer :: junit, iost, itype, ivar, k
  20    integer :: isize
  21
  22    if (trace_use) call da_trace_entry("da_setup_obs_structures_bufr")
  23
  24    !-------------------------------
  25    ! 0.0 Make thinning grids
  26    !------------------------------
  27
  28    if ( thin_conv ) then
  29       allocate(thinning_grid_conv(num_ob_indexes))
  30       do n = 1, num_ob_indexes
  31          if ( use_satwnd_bufr .and. n==polaramv ) cycle ! handled separately below
  32          if ( thin_conv_opt(n) > no_thin ) then
  33             call make3grids (n,thin_mesh_conv(n))
  34          end if
  35       end do
  36       if ( rootproc ) then ! for satwnd_bufr, thinning is done on rootproc
  37          if ( use_satwnd_bufr .and. thin_conv_opt(polaramv) > no_thin ) then
  38             if ( thin_conv_opt(polaramv) /= thin_superob_hv ) then
  39                call make3grids (polaramv, thin_mesh_conv(polaramv))
  40             else
  41                ! thin_superob_hv
  42                nplev = int(1200/thin_mesh_vert_conv(polaramv))
  43                call make3grids (polaramv, thin_mesh_conv(polaramv), thin_3d=.true., nlev=nplev)
  44             end if
  45          end if
  46       end if ! rootproc
  47    end if
  48
  49    ! check for external obs error table
  50    inquire(file='obs_errtable', exist=has_errtable)
  51    if ( has_errtable ) then
  52       allocate (oetab(300,33,6))
  53    end if
  54    if ( rootproc ) then ! only rootproc reads the file
  55      if ( has_errtable ) then
  56        call da_get_unit(junit)
  57        open(unit=junit, file='obs_errtable', form='formatted', status='old', &
  58             iostat=iost)
  59        write(unit=message(1),fmt='(A)') "Reading obs_errtable file"
  60        call da_message(message(1:1))
  61        read_loop: do while ( iost == 0 )
  62          read (junit,'(1x,i3)',iostat=iost) itype
  63          if ( itype < 100 .or. itype > 300 ) then
  64             call da_warning(__FILE__,__LINE__, (/'Error reading obs_errtable'/))
  65          end if
  66          do k = 1, 33 ! levels
  67             ! 6 columns (p coord in hPa, t, q, uv, p, pw)
  68             read (junit,'(1x,6e12.5)',iostat=iost) (oetab(itype,k,ivar),ivar=1,6)
  69          end do
  70        end do read_loop
  71        close(junit)
  72        call da_free_unit(junit)
  73      end if ! has_errtable
  74    end if ! rootproc
  75    if ( has_errtable ) then
  76      isize = 300*33*6
  77      call wrf_dm_bcast_real(oetab, isize)
  78    end if
  79
  80    !--------------------------------------------------------------------------
  81    ! [1.0] Read data
  82    !--------------------------------------------------------------------------
  83
  84       iv%time = 1
  85       call da_read_obs_bufr(iv)
  86 !
  87 !for gps
  88
  89    if ( use_gpsrefobs ) then
  90       call da_read_obs_bufrgpsro(iv)
  91    end if
  92
  93    if ( use_gpsephobs ) then
  94       call da_read_obs_bufrgpsro_eph(iv)
  95    end if
  96
  97    if ( use_satwnd_bufr ) then
  98       call da_read_obs_bufr_satwnd('satwnd.bufr', iv, ob)
  99    end if
 100
 101    if ( has_errtable ) then
 102       deallocate (oetab)
 103    end if
 104
 105    if ( thin_conv ) then
 106       do n = 1, num_ob_indexes
 107          if ( use_satwnd_bufr .and. n==polaramv ) cycle ! handled separately below
 108          if ( thin_conv_opt(n) > no_thin ) then
 109             call destroygrids_conv (n)
 110          end if
 111       end do
 112       if ( rootproc ) then ! for satwnd_bufr, thinning is done on rootproc
 113          if ( use_satwnd_bufr .and. thin_conv_opt(polaramv) > no_thin ) then
 114             if ( thin_conv_opt(polaramv) /= thin_superob_hv ) then
 115                call destroygrids_conv (polaramv)
 116             else
 117                ! thin_superob_hv
 118                call destroygrids_conv (polaramv, thin_3d=.true.)
 119             end if
 120          end if
 121       end if ! rootproc
 122       deallocate(thinning_grid_conv)
 123    end if
 124
 125    !--------------------------------------------------------------------------
 126    ! [3.0] Calculate innovation vector (O-B) and create (smaller) ob structure:
 127    !--------------------------------------------------------------------------
 128
 129    call da_fill_obs_structures(iv, ob)
 130
 131    iv%time = 1
 132
 133 #else
 134    call da_error(__FILE__,__LINE__,(/"Needs to be compiled with a BUFR library"/))
 135 #endif
 136
 137    if (trace_use) call da_trace_exit("da_setup_obs_structures_bufr")
 138
 139 end subroutine da_setup_obs_structures_bufr
 140
 141