!-------------------------------------- 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 1
#if defined (DOC)
*
***s/r SFCWNDZAP
*
*Author : C.Charette *ARMA/AES MAR 1999
*
** Purpose:
* Zap sfc wind components at land stations
*
*Arguments:
*
* none
#endif
IMPLICIT NONE
*implicits
#include "comlun.cdk"
#include "comdimo.cdk"
#include "comoabdy.cdk"
#include "comoahdr.cdk"
#include "comoba.cdk"
#include "cvcord.cdk"
#include "comnumbr.cdk"
*
INTEGER JPINEL,JPIDLND
PARAMETER(JPINEL=2,JPIDLND=9)
INTEGER J,JD,JF,JID,JOBS,JDATA,IOBS1,IOBS2,IBAD,IFLG
LOGICAL LLREJ, LLPRINT, LLOK
REAL*8 ZVAL,ZLEV,ZLEV2,ZDIFF,ZHHH,ZMODEL
INTEGER ITYP,IDATA,IDATEND,IDBURP,ITY
INTEGER ILEM,ICRIT,IBEGIN,ILAST
INTEGER ILISTEL(JPINEL),IDLND(JPIDLND)
INTEGER IKOUNTREA(JPINEL),IKOUNTREJ(JPINEL),IKOUNTT
C SYNOP(3) TEMP/PILOT(6)
DATA IDLND / 12, 14, 146, 32, 35, 135, 136, 137, 138 /
C
C
ILISTEL(1)=NEUS
ILISTEL(2)=NEVS
WRITE(NULOUT,* ) ' '
WRITE(NULOUT,* ) ' SUBROUTINE SFCWNDZAP '
WRITE(NULOUT,* ) ' '
WRITE(NULOUT,* ) '*****************************************************'
WRITE(NULOUT,222)'ELEMENTS REJECTED ',( ILISTEL(J),J=1,jpinel)
WRITE(NULOUT,222)'LIST OF IDTYP ',( idlnd(J),J=1,jpidlnd)
WRITE(NULOUT,* ) '*****************************************************'
WRITE(NULOUT,* ) ' '
LLPRINT = .FALSE.
ccc LLPRINT = .TRUE.
C
C SET COUNTERS TO ZERO
C
DO J=1,JPINEL
IKOUNTREJ(J)=0
IKOUNTREA(J)=0
END DO
IKOUNTT=0
C
C LOOP OVER OBSERVATIONS
C
DO JF = 1,NFILES
IF ( (CFAMTYP(JF) .EQ. 'SF') .AND.( NBEGINTYP(JF) .GT. 0) .OR.
& (CFAMTYP(JF) .EQ. 'UA') .AND.( NBEGINTYP(JF) .GT. 0) ) THEN
IBEGIN=NBEGINTYP(JF)
ILAST=NENDTYP(JF)
IOBS1=MOBDATA(NCMOBS,NBEGINTYP(JF))
IOBS2=MOBDATA(NCMOBS,NENDTYP(JF))
WRITE(NULOUT,'(2x,A9,2x,A2)')'FAMILY = ',CFAMTYP(JF)
C
C
DO JOBS=IOBS1,IOBS2
IF(LLPRINT) THEN
ccc CALL PRNTHDR(JOBS,NULOUT)
ccc CALL PRNTBDY(JOBS,NULOUT)
ENDIF
IDATA = MOBHDR(NCMRLN,JOBS)
IDATEND = MOBHDR(NCMNLV,JOBS) + IDATA - 1
DO JDATA= IDATA, IDATEND
C UNCONDITIONNALLY REJECT SURFACE WINDS AT SYNOP/TEMP LAND STATIONS
ITYP=MOBDATA(NCMVNM,JDATA)
ITY = MOBHDR(NCMITY,JOBS)
IDBURP = MOD(ITY,1000)
IF ( ITYP.EQ.NEUS .OR. ITYP.EQ.NEVS) THEN
DO JID = 1, JPIDLND
IF(IDBURP .EQ. IDLND(JID) .AND.
& MOBDATA(NCMASS,JDATA) .EQ. 1) THEN
MOBDATA(NCMFLG,JDATA)=
& ibset( MOBDATA(NCMFLG,JDATA) , 19 )
MOBDATA(NCMASS,JDATA)=0
DO J = 1, JPINEL
IF(ITYP .EQ.ILISTEL(J)) THEN
IKOUNTREJ(J)=IKOUNTREJ(J)+1
ENDIF
ENDDO
IF(LLPRINT) THEN
WRITE(NULOUT,225) 'Rej sfc wind lnd',JOBS,ITYP
& ,CSTNID(JOBS),IDBURP
& ,ROBHDR(NCMLAT,JOBS),ROBHDR(NCMLON,JOBS)
& ,ROBDATA8(NCMPPP,JDATA),ZDIFF
ENDIF
ENDIF
ENDDO
ENDIF
END DO
END DO
C
WRITE(NULOUT,* ) ' '
WRITE(NULOUT,* )
& '*****************************************************'
WRITE(NULOUT,222 )'ELEMENTS ', ( ILISTEL(J),J=1,JPINEL)
WRITE(NULOUT,222)'REJECTED ',(IKOUNTREJ(J),J=1,JPINEL)
WRITE(NULOUT,* )
& '*****************************************************'
WRITE(NULOUT,* ) ' '
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
ENDIF
END DO
C
IKOUNTT=0
DO JDATA=1,NDATA
IF ( MOBDATA(NCMASS,JDATA) .EQ. 1) IKOUNTT=IKOUNTT+1
END DO
WRITE(NULOUT,'(1X," NUMBER OF DATA ASSIMILATED BY 3D"
& ,"-VAR AFTER ADJUSTMENTS: ",i10)')IKOUNTT
WRITE(NULOUT,* ) ' '
RETURN
END