# 0 "" # 0 "" # 0 "" # 1 "/usr/include/stdc-predef.h" 1 3 4 # 17 "/usr/include/stdc-predef.h" 3 4 # 2 "" 2 # 1 "" # 9 "" module mod_measurement integer, parameter, public :: OBSTYPESTRLEN = 8 integer, parameter, private :: MAXNUOBS = 9 integer, public :: nuobs character(OBSTYPESTRLEN), public :: unique_obs(MAXNUOBS) integer, public :: nobseach(MAXNUOBS) integer :: uobs_begin(MAXNUOBS), uobs_end(MAXNUOBS) type measurement real d ! Measurement value real var ! Error variance of measurement character(OBSTYPESTRLEN) id ! Type of measurement ('a_i_htc1', 'a_i_tot ', 'u_ice ', 'v_ice ') real lon ! Longitude position real lat ! Latitude position real depths ! depths of position integer ipiv ! i-pivot point in grid integer jpiv ! j-pivot point in grid integer ns ! representativity in mod cells (meas. support) ! ns=0 means: point measurements ! used in m_Generate_element_Sij.F90 real a1 ! bilinear coeffisients (if ni=0) real a2 ! bilinear coeffisients real a3 ! bilinear coeffisients real a4 ! bilinear coeffisients logical status ! active or not integer i_orig_grid ! KAL - ice drift needs orig grid index as well integer j_orig_grid ! KAL - ice drift needs orig grid index as well real h ! PS - layer thickness, sorry for that integer date ! FanF- age of the data integer orig_id ! PS used in superobing end type measurement contains subroutine get_unique_obs(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 * print *, '(get_unique_obs) Getting unique obs ' end if nuobs = 0 unique_obs = '' do o = 1, nrobs obsmatch = .false. do uo = 1, MAXNUOBS 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 *, '(get_unique_obs) ERROR: # of unique obs > MAXNUOBS' end if stop end if unique_obs(nuobs) = trim(tags(o)) end if end do if (master) then do uo = 1, nuobs print *, '(get_unique_obs) 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 *, '(get_unique_obs) ERROR: unique observations not ',& 'continuous in observation array' stop end if end do end do end if end subroutine get_unique_obs end module mod_measurement