!--------------------------------------- LICENCE BEGIN -----------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
#include "maincompileswitch.inc"
#include "compileswitches.inc"
SUBROUTINE ADJUST_HUM_GZ(obsdat,START,END) 1
!**s/r ADJUST_HUM_GZ - Adjust t-td and GZ in obsdat
!
!
!Author : P. Koclas *CMC/CMDA April 2013
!Revision:
!
!* Purpose: - Adjust t-td values to zesmax=30. in obsdat
! set Z to GZ in obsdat
!
!
!Arguments
!
! INPUT:
! -OBSDAT : instance of obsspace_data module object
! -START : FIRST OBERVATION
! -END : LAST OBERVATION
!
use ObsSpaceData_mod
use bufr
use EarthConstants_mod
!
IMPLICIT NONE
INTEGER :: START,END
INTEGER :: J,JO,RLN,NLV
INTEGER :: VARNO
type (struct_obs), intent(inout):: obsdat
REAL(OBS_REAL) :: ZESMAX,GZ,OBSV
REAL :: RMIN
!-----------------------
ZESMAX=30.0
!-----------------------
!-----------------------------------------------------------------------
WRITE(*,*)' ADJUST_HUM_GZ '
!
!-----------------------------------
! STN LOOP
!-----------------------------------
! DO JO=1,obs_numheader(obsdat)
DO JO=START,END
RLN=obs_headElem_i(obsdat,OBS_RLN,JO)
NLV=obs_headElem_i(obsdat,OBS_NLV,JO)
!=================================
! DATA LOOP
!=================================
DO J = RLN, NLV + RLN -1
VARNO=obs_bodyElem_i(obsdat,OBS_VNM,j)
SELECT CASE(VARNO)
CASE(BUFR_NEES,BUFR_NESS)
OBSV=obs_bodyElem_r(obsdat,OBS_VAR,j)
IF ( OBSV .GT. ZESMAX) THEN
OBSV=ZESMAX
ENDIF
call obs_bodySet_r(obsdat,OBS_VAR,j, OBSV )
CASE(BUFR_NEGZ)
OBSV=obs_bodyElem_r(obsdat,OBS_VAR,j)
GZ=OBSV*GRAV
call obs_bodySet_r(obsdat,OBS_VAR,j,GZ )
END SELECT
!
END DO
!=================================
!
END DO
!-----------------------------------
!
WRITE(*,*)' DONE ADJUST_HUM_GZ '
RETURN
END SUBROUTINE ADJUST_HUM_GZ
SUBROUTINE SET_ERR_GBGPS(obsdat,START,END) 1
!**s/r SET_ERR_GBGPS - SET INITIAL ERROR FRO GROUND BASED GPS
!
!
!Author : P. Koclas *CMC/CMDA July 2013
!Revision:
!
!* Purpose: - PUT 15032 observation element as error of 15031 element in obsdat
!
!
!Arguments
!
! INPUT:
! -OBSDAT : instance of obsspace_data module object
! -START : FIRST OBERVATION
! -END : LAST OBERVATION
!
use ObsSpaceData_mod
!
IMPLICIT NONE
INTEGER :: START,END
INTEGER :: J,JO,RLN,NLV
INTEGER :: VARNO
type (struct_obs), intent(inout):: obsdat
REAL(OBS_REAL) :: OBSV
REAL :: MISG
!-----------------------------------------------------------------------
WRITE(*,*)' SET_ERR_GBGPS '
MISG=-999.
!
!-----------------------------------
! STN LOOP
!-----------------------------------
DO JO=START,END
RLN=obs_headElem_i(obsdat,OBS_RLN,JO)
NLV=obs_headElem_i(obsdat,OBS_NLV,JO)
!=================================
! DATA LOOP
!=================================
OBSV=MISG
DO J = RLN, NLV + RLN -1
VARNO=obs_bodyElem_i(obsdat,OBS_VNM,j)
IF ( VARNO .eq. 15032 ) THEN
OBSV=obs_bodyElem_r(obsdat,OBS_VAR,j)
call obs_bodySet_i(obsdat,OBS_VNM,j,999 )
EXIT
ENDIF
!
END DO
DO J = RLN, NLV + RLN -1
VARNO=obs_bodyElem_i(obsdat,OBS_VNM,j)
IF ( VARNO .eq. 15031 .and. OBSV .ne. MISG ) THEN
call obs_bodySet_r(obsdat,OBS_OER,j,OBSV )
EXIT
ENDIF
!
END DO
!=================================
!
END DO
!-----------------------------------
!
WRITE(*,*)' DONE SET_ERR_GBGPS '
RETURN
END SUBROUTINE SET_ERR_GBGPS
SUBROUTINE ADJUST_SFVCOORD(obsdat,START,END) 1
!
!**s/r ADJUST_SFVCOORD - Computation of HEIGHT ASSIGNED TO SURFACE OBSERVATIONS
!
!
!Author : P. Koclas *CMC/CMDA April 2013
!Revision:
! S. Macpherson *ARMA Oct 2013
! -- add GB-GPS (GP family) element BUFR_NEZD (ele 15031)
! -- NOTE that for GP data, ELEV = GPS Antenna Height so
! no adjustment is needed (SFC_VCO=0).
!
!* Purpose: -Compute HEIGHT ASSIGNED TO SURFACE OBSERVATIONS
! and INSERT INTO CMA.
!
!
!Arguments
! INPUT:
! -OBSDAT : instance of obsspace_data module object
! -START : FIRST OBERVATION
! -END : LAST OBERVATION
!
use ObsSpaceData_mod
use bufr
!
IMPLICIT NONE
INTEGER :: START,END
REAL :: SURFVCORD
INTEGER :: J,JO,RLN,NLV
INTEGER :: VARNO,CODTYP,ITY
REAL :: SFC_VCO,ELEV
REAL(OBS_REAL) :: PPP
type (struct_obs), intent(inout):: obsdat
!-----------------------------------------------------------------------
WRITE(*,*)' ADJUST_SFVCOORD '
!
!-----------------------------------
! STN LOOP
!-----------------------------------
! DO JO=1,obs_numheader(obsdat)
DO JO=START,END
RLN=obs_headElem_i(obsdat,OBS_RLN,JO)
NLV=obs_headElem_i(obsdat,OBS_NLV,JO)
ITY=obs_headElem_i(obsdat,OBS_ITY,JO)
CODTYP = ITY
!=================================
! DATA LOOP
!=================================
ELEV=obs_headElem_r(obsdat,OBS_ALT,JO)
DO J = RLN, NLV + RLN -1
VARNO=obs_bodyElem_i(obsdat,OBS_VNM,j)
SELECT CASE(VARNO)
CASE(BUFR_NEDS,BUFR_NEFS,BUFR_NEUS,BUFR_NEVS,BUFR_NETS,BUFR_NESS,BUFR_NEPN,BUFR_NEPS,BUFR_NEHS,BUFR_NEZD)
! CASE(11011,11012,11215,11216,12004,12203,10051,10004,13220,15031)
!
SFC_VCO= SURFVCORD(VARNO,CODTYP)
IF ( VARNO .ne. BUFR_NEPN) THEN
PPP=ELEV + SFC_VCO
call obs_bodySet_r(obsdat,OBS_PPP,j,PPP)
call obs_bodySet_i(obsdat,OBS_VCO,j,1)
ELSE
PPP=0.
call obs_bodySet_r(obsdat,OBS_PPP,j,PPP)
call obs_bodySet_i(obsdat,OBS_VCO,j,1)
ENDIF
END SELECT
END DO
!=================================
!
END DO
!-----------------------------------
!
WRITE(*,*)' DONE ADJUST_SFVCOORD '
RETURN
END SUBROUTINE ADJUST_SFVCOORD
REAL FUNCTION SURFVCORD(ILEM,IDTYP) 1,1
!
use bufr
implicit none
INTEGER ILEM,IDTYP,TYPE
! REAL SURFVCORD
REAL VCORDSF2
!
!***********************************************************************
!
! PURPOSE: SEt vertical coordinate for surface data.
!
! AUTHOR: P. KOCLAS (CMC/CMDA) December 2011
!
! Revision :
!
! ARGUMENTS:
! INPUT:
! -ILEMP : BURP ELEMENT NUMBER
! -IDTYP : BURP CODETYPE
!
! OUTPUT:
! -SURFVCORD
!
!
!***********************************************************************
!
!
! GENERATE TABLES TO ADJUST VERTICAL COORDINATE OF SURFACE DATA
!
! DEFAULT VALUE
! =====================
vcordsf2=0.
! =====================
select case(IDTYP)
case(135,136,137,138,32,34,35,37,38,159,160,161,162)
! -----------------
! UPPER AIR LAND
! -----------------
TYPE=3
case(139,140,141,142,33,36)
! -----------------
! UPPER AIR SHIP
! -----------------
TYPE=4
case(12,14,146)
! -----------------
! SYNOPS
! -----------------
TYPE=1
case(13,18,145,147)
! -----------------
! SHIPS
! -----------------
TYPE=2
case(254)
! --------------------
! SCATTEROMETER WINDS
! --------------------
TYPE=5
! -----------------
case default
! -----------------
TYPE=-99
end select
!
select case(TYPE)
!===================================================================
case (1)
select case(ilem)
! case (11011,11012,11215,11216)
case (BUFR_NEDS,BUFR_NEFS,BUFR_NEUS,BUFR_NEVS)
! us,vs,ffs,dds
! ==============
vcordsf2=10.0
! ==============
! case (11051)
case (BUFR_NEPN)
! pnm
! ==============
vcordsf2=0.0
! ==============
! ps
! case (10004)
case (BUFR_NEPS)
! ==============
vcordsf2=0.0
! ==============
! ts
! case (12004)
case (BUFR_NETS)
! ==============
vcordsf2=1.5
! ==============
! t-td
! case (12192,12203)
case (BUFR_NEES,BUFR_NESS)
! ==============
vcordsf2=1.5
! ==============
end select
!===================================================================
!===================================================================
case (2)
select case(ilem)
! us,vs,ffs,dds
! case (11011,11012,11215,11216)
case (BUFR_NEDS,BUFR_NEFS,BUFR_NEUS,BUFR_NEVS)
! ==============
vcordsf2=20.0
! ==============
! case (11051)
case (BUFR_NEPN)
! pnm
! ==============
vcordsf2=0.0
! ==============
! case (10004)
case (BUFR_NEPS)
! ps
! ==============
vcordsf2=0.0
! ==============
! case (12004)
case (BUFR_NETS)
! ts
! ==============
vcordsf2=11.5
! ==============
! case (12192,12203)
case (BUFR_NEES,BUFR_NESS)
! t-td
! ==============
vcordsf2=11.5
! ==============
end select
!===================================================================
!===================================================================
case (3)
select case(ilem)
! case (11011,11012,11215,11216)
case (BUFR_NEDS,BUFR_NEFS,BUFR_NEUS,BUFR_NEVS)
vcordsf2=10.0
! case (11051)
case (BUFR_NEPN)
! pnm
! ===============
vcordsf2=0.0
! ===============
! case (10004)
case (BUFR_NEPS)
! ps
! ===============
vcordsf2=0.0
! ===============
! case (12004)
case (BUFR_NETS)
! ts
! ===============
vcordsf2=1.5
! ===============
! case (12192)
case (BUFR_NEES)
! t-td
! ===============
vcordsf2=0.0
! ===============
! t-td(surf)
! case (12203)
case (BUFR_NESS)
! ===============
vcordsf2=1.5
! ===============
end select
!===================================================================
!===================================================================
case (4)
select case(ilem)
! case (11011,11012,11215,11216)
case (BUFR_NEDS,BUFR_NEFS,BUFR_NEUS,BUFR_NEVS)
! ===============
vcordsf2=20.0
! ===============
! case (11051)
case (BUFR_NEPN)
! pnm
! ===============
vcordsf2=0.0
! ===============
! case (10004)
case (BUFR_NEPS)
! ps
! ===============
vcordsf2=0.0
! ===============
! case (12004)
case (BUFR_NETS)
! ts
! ===============
vcordsf2=1.5
! ===============
! t-td
! case (12192)
case (BUFR_NEES)
! ===============
vcordsf2=0.0
! ===============
! case (12203)
case (BUFR_NESS)
! ===============
vcordsf2=1.5
! ===============
end select
!===================================================================
!===================================================================
case (5)
select case(ilem)
! case (11011,11012,11215,11216)
case (BUFR_NEDS,BUFR_NEFS,BUFR_NEUS,BUFR_NEVS)
! ===============
vcordsf2=10.0
! ===============
end select
!===================================================================
end select
!
! *******************
SURFVCORD=VCORDSF2
! *******************
!
RETURN
END FUNCTION SURFVCORD
SUBROUTINE FDTOUV_OBSDAT(obsdat,START,END,PPMIS) 1,45
!
!---------------------------------------------------------------
!
! Author : P. Koclas, CMC/CMDA December 2012
! CONVERT DD , FF WINDS TO
! UU (est-west), VV (north-south) COMPONENTS
!
! ARGUMENTS:
! INPUT:
!
! -obsdat : CMA_table INSTANCE
! -START : FIRST OBERVATION
! -END : LAST OBERVATION
! -PPMIS : MISSING VALUE
!
! **************************************************
! IT IS ASSUMED THAT CMA CONTAINS ENTRIES FOR
! UU AND VV with observed values = missing value
! **************************************************
!
!---------------------------------------------------------------
!
use ObsSpaceData_mod
use bufr
use MathPhysConstants_mod
implicit none
type (struct_obs), intent(inout) :: obsdat
REAL*4 :: PPMIS
INTEGER*4 :: START,END
INTEGER*4 :: VARNO,VARNO2,VARNO4
REAL*4 :: OBSUV
INTEGER*4 :: JO,RLN,NLV,j,j2,j4,Jpos,ilem
INTEGER*4 :: DDFLAG,FFFLAG,NEWFLAG,UUFLAG,VVFLAG
INTEGER*4 :: ILEMF,ILEMU,ILEMV,INDU_MISG,INDV_MISG,INDUM,INDVM
LOGICAL :: LLMISDD,LLMISFF,LLMIS,LLUV_misg,LLU_misg,LLV_misg
LOGICAL :: LLUV_PRESENT,LLU_PRESENT,LLV_PRESENT
INTEGER :: NOBSOUT
REAL(OBS_REAL) :: UU,VV,DD,FF
REAL(OBS_REAL) :: LEVEL_DD,LEVEL4,LEVEL,LEVEL_UU
NOBSOUT=6
FFFLAG=0 ! bhe
!--------------------------------
! HEADER LOOP
!--------------------------------
HEADER1: do JO=START,END
RLN=obs_headElem_i(obsdat,OBS_RLN,JO)
NLV=obs_headElem_i(obsdat,OBS_NLV,JO)
!--------------------------------
! TOP DATA LOOP
!--------------------------------
DO J = RLN, NLV + RLN -1
DD=PPMIS
FF=PPMIS
VARNO=obs_bodyElem_i(obsdat,OBS_VNM,j)
LLMISDD =.true.
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++
SELECT case (VARNO)
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++
case (BUFR_NEDD,BUFR_NEDS)
IF( VARNO .eq. BUFR_NEDS) then
ILEMF=BUFR_NEFS
ILEMU=BUFR_NEUS
ILEMV=BUFR_NEVS
ELSE
ILEMF=BUFR_NEFF
ILEMU=BUFR_NEUU
ILEMV=BUFR_NEVV
ENDIF
DD =obs_bodyElem_r(obsdat,OBS_VAR,j)
DDFLAG =obs_bodyElem_i(obsdat,OBS_FLG,j)
LEVEL_dd=obs_bodyElem_r(obsdat,OBS_PPP,j)
LLU_misg=.false.
LLV_misg=.false.
LLU_PRESENT=.false.
LLV_PRESENT=.false.
INDUM=-1
INDVM=-1
! FIND IF U AND V ARE ALREADY IN CMA
!-------------------------------------
uvinobsdat: do J4 =J, NLV + RLN -1
!-------------------------------------
LEVEL4=obs_bodyElem_r(obsdat, OBS_PPP,j4)
IF (LEVEL4 .eq. LEVEL_dd) then
VARNO4=obs_bodyElem_i(obsdat, OBS_VNM,j4)
SELECT case (VARNO4)
case (11003,11004,11002,11001,11215,11216,11011,11012)
OBSUV =obs_bodyElem_r(obsdat, OBS_VAR,j4)
IF ( (VARNO4 .eq. ILEMU) .and. (obsuv .ne. PPMIS) ) THEN
LLU_PRESENT=.true.
INDUM=J4
ELSE IF ( (VARNO4 .eq. ILEMV) .and. (obsuv .ne. PPMIS) ) THEN
LLV_PRESENT=.true.
INDVM=J4
ENDIF
IF ( (VARNO4 .eq. ILEMU) .and. (obsuv .eq. PPMIS) ) THEN
LLU_misg=.true.
INDU_MISG=J4
ELSEIF ( (VARNO4 .eq. ILEMV) .and. (obsuv .eq. PPMIS) ) THEN
LLV_misg=.true.
INDV_MISG=J4
ENDIF
END SELECT
ENDIF
!-------------------------------------
end do uvinobsdat
!-------------------------------------
LLUV_misg= (LLU_misg .and. LLV_misg)
LLUV_PRESENT= (LLU_PRESENT .and. LLV_PRESENT)
! *******************************
IF ( LLUV_misg) THEN
! *******************************
!---------------------------------
calcuv: do J2 =J, NLV + RLN -1
!---------------------------------
LLMISFF =.true.
LLMISDD =.true.
LLMIS =.true.
LEVEL=obs_bodyElem_r(obsdat,OBS_PPP,j2)
if ( LEVEL .ne. LEVEL_dd) cycle
VARNO2=obs_bodyElem_i(obsdat,OBS_VNM,j2)
!==VARNO2=============================================
IF ( (VARNO2) .eq. ILEMF ) THEN
FF =obs_bodyElem_r(obsdat,OBS_VAR,j2)
FFFLAG=obs_bodyElem_i(obsdat,OBS_FLG,j2)
IF ( (DD .EQ. 0. .AND. FF .GT. 0.) .or. ( DD .GT. 360. .OR. DD .LT.0.) ) THEN
LLMISDD =.true.
LLMISFF =.true.
ELSE IF ( DD .eq. PPMIS .OR. FF .eq. PPMIS) THEN
LLMISDD =.true.
LLMISFF =.true.
ELSE
LLMISDD=.false.
LLMISFF=.false.
ENDIF
!
! IF SPEED = 0 CALM WIND IS ASSUMED.
! ==================================
IF (FF .EQ. 0.0) THEN
DD = 0.
ENDIF
!
DD=DD + 180.
IF ( DD .GT. 360.) DD=DD-360.
DD=DD*MPC_RADIANS_PER_DEGREE_R8
! U,V COMPONENTS ARE
!==============================================
UU =FF*SIN(DD)
VV =FF*COS(DD)
!==============================================
if ( ( llmisdd .eqv. .true.) .or. ( llmisff .eqv. .true. ) ) then
llmis=.true.
if ( INDU_MISG .GT. 0 .or. INDV_MISG .GT. 0 ) then
call obs_bodySet_i(obsdat,OBS_VNM,INDU_MISG,-1)
call obs_bodySet_i(obsdat,OBS_VNM,INDV_MISG,-1)
endif
else
llmis=.false.
endif
ENDIF
NEWFLAG = IOR(DDFLAG,FFFLAG)
if ( INDUM .GT. 0 .or. INDVM .GT. 0 ) then
call obs_bodySet_i(obsdat,OBS_VNM,INDU_MISG,-1)
call obs_bodySet_i(obsdat,OBS_VNM,INDV_MISG,-1)
endif
IF (llmis .eqv. .true.) THEN
if ( INDUM .GT. 0 .or. INDVM .GT. 0 ) then
call obs_bodySet_i(obsdat,OBS_FLG,induM,NEWFLAG)
call obs_bodySet_i(obsdat,OBS_FLG,indvM,NEWFLAG)
endif
ELSE IF (llmis .eqv. .false.) THEN
call obs_bodySet_r(obsdat,OBS_VAR,INDU_MISG,UU)
call obs_bodySet_i(obsdat,OBS_FLG,INDU_MISG,NEWFLAG)
call obs_bodySet_r(obsdat,OBS_VAR,INDV_MISG,VV)
call obs_bodySet_i(obsdat,OBS_FLG,INDV_MISG,NEWFLAG)
ENDIF
!
!---------------------
END DO calcuv
!---------------------
! *******************************
ELSE
! *******************************
IF ( LLUV_PRESENT .eqv. .true. ) THEN
call obs_bodySet_i(obsdat,OBS_VNM,INDU_MISG,-1)
call obs_bodySet_i(obsdat,OBS_VNM,INDV_MISG,-1)
ELSE
if (indum .gt. 0) then
call obs_bodySet_i(obsdat,OBS_VNM,indum,-1)
endif
if (indvm .gt. 0) then
call obs_bodySet_i(obsdat,OBS_VNM,indvm,-1)
endif
ENDIF
! *******************************
ENDIF
! *******************************
!---------------------
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++
END SELECT
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!--------------------------------
! END TOP DATA LOOP
!--------------------------------
end do
enddo HEADER1
!==========================================================================================
! do JO=1,obs_numHeader(obsdat)
do JO=START,END
RLN=obs_headElem_i(obsdat,OBS_RLN,JO)
NLV=obs_headElem_i(obsdat,OBS_NLV,JO)
!--------------------------------
! DATA LOOP
!--------------------------------
DO J = RLN, NLV + RLN -1
LLMISDD =.true.
VARNO=obs_bodyElem_i(obsdat,OBS_VNM,J)
LEVEL=obs_bodyElem_r(obsdat,OBS_PPP,J)
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++
SELECT case (VARNO)
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++
case (BUFR_NEUU)
ILEM=BUFR_NEVV
case (BUFR_NEUS)
ILEM=BUFR_NEVS
! case (BUFR_NEVV)
! ILEM=BUFR_NEUU
! case (BUFR_NEVS)
! ILEM=BUFR_NEUS
case default
cycle
Jpos=0
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++
END SELECT
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Jpos=-1
!---------------------------------------------------------------------
!TRANSFER THE FLAG BITS FROM ONE WIND COMPONENT TO THE OTHER
!---------------------------------------------------------------------
DO J4 = RLN, NLV + RLN -1
UU =obs_bodyElem_r(obsdat,OBS_VAR,J4)
LEVEL_UU=obs_bodyElem_r(obsdat,OBS_PPP,J4)
Jpos=-1
!
if ( LEVEL_UU .eq. LEVEL .and. UU .eq. PPMIS ) then
call obs_bodySet_i(obsdat,OBS_VNM,J4,-1)
endif
!
if ( LEVEL_UU .eq. LEVEL .and. UU .ne. PPMIS ) then
UUFLAG =obs_bodyElem_i(obsdat,OBS_FLG,J4)
VARNO2 =obs_bodyElem_i(obsdat,OBS_VNM,J4)
! SELECT case (VARNO2)
! case (BUFR_NEUU,BUFR_NEUS,BUFR_NEVV,BUFR_NEVS)
!============================================================
IF ( (ILEM .eq. VARNO2) ) THEN
VVFLAG =obs_bodyElem_i(obsdat,OBS_FLG,J)
NEWFLAG =IOR(UUFLAG,VVFLAG)
call obs_bodySet_i(obsdat,OBS_FLG,J, NEWFLAG)
call obs_bodySet_i(obsdat,OBS_FLG,J4,NEWFLAG)
Jpos=J4
exit
ENDIF
!============================================================
! END SELECT
endif
!----------------------------------------------------------------
END DO !J4
!----------------------------------------------------------------
!---------------------------------------------------------------------
!ELIMINATE ENTRIES WHERE ONE COMPONENT OF WIND (UU OR VV) IS MISSING
!---------------------------------------------------------------------
if (Jpos .lt. 0) then
WRITE(*,*) ' eliminate winds for station : ',obs_elem_c(obsdat,'STID',JO),obs_bodyElem_i (obsdat,OBS_VNM,J),obs_bodyElem_r(obsdat,OBS_PPP,J)
call obs_bodySet_i(obsdat,OBS_VNM,J,-1)
endif
!--------------------------------
END DO !J
!--------------------------------
END DO !JO
!==========================================================================================
END SUBROUTINE FDTOUV_OBSDAT
SUBROUTINE FLAGUVTOFD_OBSDAT(lobsSpaceData) 1,20
!
!**s/r FLAGUVTOFD_OBSDAT - Update WIND DIRECTION AND SPEED FLAGS
!
!
!Author : P. Koclas *CMC/CMDA April 2013
!
!
!Arguments
!
use MathPhysConstants_mod
use obsSpaceData_mod
use bufr
IMPLICIT NONE
!
type(struct_obs) :: lobsSpaceData
INTEGER :: IUU,IVV,IFF,IDD
INTEGER :: FLAGU,FLAGV,NEWFLAG
INTEGER :: INDEX_HEADER,ISTART,IEND,jwintyp
INTEGER :: INDEX_BODY,INDEX_BODY2
REAL*8 :: ZLEVU
LOGICAL :: LLOK
CHARACTER*9 :: STID
!-----------------------------------------------------------------------
!
WIND_TYPE: do jwintyp=1,2
if (jwintyp .eq. 1) then
IUU=BUFR_NEUU
IVV=BUFR_NEVV
IDD=BUFR_NEDD
IFF=BUFR_NEFF
else
IUU=BUFR_NEUS
IVV=BUFR_NEVS
IDD=BUFR_NEDS
IFF=BUFR_NEFS
endif
!
!
!
BODY: DO INDEX_BODY=1,obs_numBody(lobsSpaceData)
LLOK= ( obs_bodyElem_i(lobsSpaceData,OBS_VNM,INDEX_BODY) .EQ. IUU)
FLAGU=-1
!----------------
IF ( LLOK ) THEN
!----------------
INDEX_HEADER = obs_bodyElem_i(lobsSpaceData,OBS_HIND,INDEX_BODY)
ISTART = obs_headElem_i(lobsSpaceData,OBS_RLN,INDEX_HEADER)
IEND=obs_headElem_i(lobsSpaceData,OBS_NLV,INDEX_HEADER) +ISTART-1
STID=obs_elem_c(lobsSpaceData,'STID',INDEX_HEADER)
ZLEVU = obs_bodyElem_r(lobsSpaceData,OBS_PPP,INDEX_BODY)
!
!****************************************************************************
! GET FLAG OF U COMPONENT
!***********************************************************************
!
FLAGU=obs_bodyElem_i(lobsSpaceData,OBS_FLG,INDEX_BODY)
BODY_2: DO INDEX_BODY2=ISTART,IEND
IF ( ( obs_bodyElem_i(lobsSpaceData,OBS_VNM,INDEX_BODY2) .EQ. IVV) &
.AND. ( obs_bodyElem_r(lobsSpaceData,OBS_PPP,INDEX_BODY2) .EQ. ZLEVU) ) THEN
!
!****************************************************************************
! GET FLAG OF V COMPONENT
!***********************************************************************
!
FLAGV= obs_bodyElem_i(lobsSpaceData,OBS_FLG,INDEX_BODY2)
NEWFLAG =IOR(FLAGU,FLAGV)
!
ENDIF
ENDDO BODY_2
!
!***********************************************************************
! UPDATE FLAGS OF DIRECTION AN SPEED
!***********************************************************************
!
BODY_2_2: DO INDEX_BODY2=ISTART,IEND
!===============================================
IF ((obs_bodyElem_i(lobsSpaceData,OBS_VNM,INDEX_BODY2).EQ.IDD) &
.AND. obs_bodyElem_r(lobsSpaceData,OBS_PPP,INDEX_BODY2) .EQ. ZLEVU ) THEN
NEWFLAG =IOR(FLAGU,FLAGV)
call obs_bodySet_i(lobsSpaceData, OBS_FLG, INDEX_BODY2, NEWFLAG)
ENDIF
!===============================================
!===============================================
IF ((obs_bodyElem_i(lobsSpaceData,OBS_VNM,INDEX_BODY2).EQ.IFF) &
.AND. obs_bodyElem_r(lobsSpaceData,OBS_PPP,INDEX_BODY2) .EQ. ZLEVU ) THEN
NEWFLAG =IOR(FLAGU,FLAGV)
call obs_bodySet_i(lobsSpaceData,OBS_FLG,INDEX_BODY2, NEWFLAG)
ENDIF
!===============================================
ENDDO BODY_2_2
!----------------
ENDIF
!----------------
ENDDO BODY
ENDDO WIND_TYPE
RETURN
END SUBROUTINE FLAGUVTOFD_OBSDAT