EnKF/EnKF-MPI-TOPAZ/TMP/m_uobs.f90

# 0 "<stdin>"
# 0 "<built-in>"
# 0 "<command-line>"


# 1 "/usr/include/stdc-predef.h" 1 3 4

# 17 "/usr/include/stdc-predef.h" 3 4











































# 2 "<command-line>" 2
# 1 "<stdin>"
# 10 "<stdin>"
! File:          m_uobs.F90
!
! Created:       11 August 2010
!
! Last modified: 11.8.2010
!
! Author:        Pavel Sakov
!                NERSC
!
! Purpose:       Handle different observation types.
!
! Description:   This module is in charge of sorting of observations by types
!                and storing the results
!
! Modifications: None

module m_uobs

    use qmpi



  use mod_measurement
  implicit none

  public uobs_get
  
  integer, parameter, private :: MAXNUOBS = 1900

  integer, public :: nuobs
  character(OBSTYPESTRLEN), public :: unique_obs(MAXNUOBS)
  integer, public :: nobseach(MAXNUOBS)
  integer :: uobs_begin(MAXNUOBS), uobs_end(MAXNUOBS)

contains

  subroutine uobs_get(tags, nrobs, master)
    implicit none
    integer , intent(in) :: nrobs
    logical , intent(in) :: master
    character(OBSTYPESTRLEN), intent(in) :: tags(nrobs)

    logical :: obsmatch
    integer :: o, uo

    nobseach = 0

    ! check for unique obs
    if (master) then
       print '(a)', ' EnKF: getting unique observations '
    end if
    nuobs = 0
    unique_obs = ''
    do o = 1, nrobs
       !PRINT *, o
       !PRINT *, '...', nuobs
       obsmatch = .false.
       do uo = 1, nuobs
          !PRINT *, '-->', uo
          if (trim(tags(o)) == trim(unique_obs(uo))) then
             obsmatch = .true.
             nobseach(uo) = nobseach(uo) + 1
             exit
          end if
       end do
       if (.not. obsmatch) then
          nuobs = nuobs + 1
          nobseach(nuobs) = 1
          if (nuobs > MAXNUOBS) then
             if (master) then
                print *, 'ERROR: uobs_get(): # of unique obs = ', nuobs,&
                     ' > MAXNUOBS = ', MAXNUOBS
                print *, '  obs # = ', o, ', tag = ', trim(tags(o))
             end if
             stop
          end if
          unique_obs(nuobs) = trim(tags(o))
       end if
    end do
    if (master) then
       do uo = 1, nuobs
          print '(a, i2, a, a, a, i7, a)', '   obs variable  ', uo, ' -- ',&
               trim(unique_obs(uo)), ',', nobseach(uo), ' observations'
       end do
    end if
    uobs_begin(1) = 1
    uobs_end(1) = nobseach(1)
    do uo = 2, nuobs
       uobs_begin(uo) = uobs_end(uo - 1) + 1
       uobs_end(uo) = uobs_begin(uo) + nobseach(uo) - 1
    end do
    if (master) then
       do uo = 1, nuobs
          do o = uobs_begin(uo), uobs_end(uo)
             if (trim(tags(o)) /= trim(unique_obs(uo))) then
                print *, trim(tags(o))
                print *, trim(unique_obs(uo))
                print *, 'ERROR: uobs_get(): uinique observations not ',&
                     'continuous in observation array'
                stop
             end if
          end do
       end do
    end if
    if (master) then
       print *
    end if
  end subroutine uobs_get

end module m_uobs