!-------------------------------------- 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 --------------------------------------
!
SUBROUTINE SFCWNDZAP(lobsSpaceData) 1,17
#if defined (DOC)
*
***s/r SFCWNDZAP
*
*Author : C.Charette *ARMA/AES MAR 1999
*
** Purpose:
* Zap sfc wind components at land stations
*
*Arguments:
*
* none
#endif
use obsSpaceData_mod
use bufr
IMPLICIT NONE
type(struct_obs) :: lobsSpaceData
INTEGER JPINEL,JPIDLND
PARAMETER(JPINEL=2,JPIDLND=9)
INTEGER J,JID,JDATA
LOGICAL LLPRINT
REAL(8) ZDIFF
INTEGER ITYP,IDBURP
INTEGER ILISTEL(JPINEL),IDLND(JPIDLND)
INTEGER IKOUNTREJ(JPINEL),IKOUNTT
C SYNOP(3) TEMP/PILOT(6)
character(len=2), dimension(2) :: list_family
integer :: index_family, index_header, index_body
DATA IDLND / 12, 14, 146, 32, 35, 135, 136, 137, 138 /
C
C
ILISTEL(1)=BUFR_NEUS
ILISTEL(2)=BUFR_NEVS
WRITE(*,* ) ' '
WRITE(*,* ) ' SUBROUTINE SFCWNDZAP '
WRITE(*,* ) ' '
WRITE(*,* ) '*****************************************************'
WRITE(*,222)'ELEMENTS REJECTED ',( ILISTEL(J),J=1,jpinel)
WRITE(*,222)'LIST OF IDTYP ',( idlnd(J),J=1,jpidlnd)
WRITE(*,* ) '*****************************************************'
WRITE(*,* ) ' '
LLPRINT = .FALSE.
ccc LLPRINT = .TRUE.
C
C SET COUNTERS TO ZERO
C
DO J=1,JPINEL
IKOUNTREJ(J)=0
END DO
!
! Loop over the families of interest
!
list_family(1) = 'SF'
list_family(2) = 'UA'
do index_family = 1,2
WRITE(*,'(2x,A9,2x,A2)')'FAMILY = ',list_family(index_family)
!
! loop over all header indices of each family
!
! Set the header list
! (& start at the beginning of the list)
call obs_set_current_header_list(lobsSpaceData,
& list_family(index_family))
HEADER: do
index_header = obs_getHeaderIndex(lobsSpaceData)
if (index_header < 0) exit HEADER
!
! loop over all body indices (still in the same family)
!
! Set the body list
! (& start at the beginning of the list)
call obs_set_current_body_list(lobsSpaceData, index_header)
BODY: do
index_body = obs_getBodyIndex(lobsSpaceData)
if (index_body < 0) exit BODY
C UNCONDITIONALLY REJECT SURFACE WINDS AT SYNOP/TEMP LAND STATIONS
ITYP=obs_bodyElem_i(lobsSpaceData,OBS_VNM,INDEX_BODY)
IDBURP = obs_headElem_i(lobsSpaceData,OBS_ITY,INDEX_HEADER)
IF ( ITYP.EQ.BUFR_NEUS .OR. ITYP.EQ.BUFR_NEVS) THEN
DO JID = 1, JPIDLND
IF(IDBURP .EQ. IDLND(JID) .AND.
& obs_bodyElem_i(lobsSpaceData,OBS_ASS,INDEX_BODY) .EQ. 1) THEN
call obs_bodySet_i(lobsSpaceData,OBS_FLG,INDEX_BODY,
& ibset( obs_bodyElem_i(lobsSpaceData,OBS_FLG,INDEX_BODY), 19))
call obs_bodySet_i(lobsSpaceData,OBS_ASS,INDEX_BODY,0)
DO J = 1, JPINEL
IF(ITYP .EQ.ILISTEL(J)) THEN
IKOUNTREJ(J)=IKOUNTREJ(J)+1
ENDIF
ENDDO
IF(LLPRINT) THEN
WRITE(*,225) 'Rej sfc wind lnd',INDEX_HEADER,ITYP
& ,obs_elem_c(lobsSpaceData,'STID',INDEX_HEADER),IDBURP
& ,obs_headElem_r(lobsSpaceData,OBS_LAT,INDEX_HEADER)
& ,obs_headElem_r(lobsSpaceData,OBS_LON,INDEX_HEADER)
& ,obs_bodyElem_r(lobsSpaceData,OBS_PPP,INDEX_BODY),ZDIFF
ENDIF
ENDIF
ENDDO
ENDIF ! BUFR_NEUS or BUFR_NEVS
END DO BODY
END DO HEADER
C
WRITE(*,* ) ' '
WRITE(*,* )
& '*****************************************************'
WRITE(*,222 )'ELEMENTS ', ( ILISTEL(J),J=1,JPINEL)
WRITE(*,222)'REJECTED ',(IKOUNTREJ(J),J=1,JPINEL)
WRITE(*,* )
& '*****************************************************'
WRITE(*,* ) ' '
222 FORMAT(2x,a29,10(2x,i5))
223 FORMAT(2x,a29,10(2x,f5.0))
224 FORMAT(2x,a17,2x,I6,2X,I5,1x,a9,1x,2(2x,f9.2))
225 FORMAT(2x,a13,2x,I6,2X,I5,1x,a9,1x,I6,1x,4(2x,f9.2))
C
END DO ! family
C
IKOUNTT=0
DO JDATA=1,obs_numbody(lobsSpaceData)
IF ( obs_bodyElem_i(lobsSpaceData,OBS_ASS,JDATA) .EQ. 1) IKOUNTT=IKOUNTT+1
END DO
WRITE(*,'(1X," NUMBER OF DATA ASSIMILATED BY 3D"
& ,"-VAR AFTER ADJUSTMENTS: ",i10)')IKOUNTT
WRITE(*,* ) ' '
RETURN
END