!-------------------------------------- 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 FLAGWND(KFLAG,KLIST,KNELE,KNVAL,KINT 2,2
& ,CSTN,KIDBRP,KLAT,KLON)
IMPLICIT NONE
#include "comlun.cdk"
#include "cparbrp.cdk"
#include "comfilt.cdk"
CCC
INTEGER KNELE,KNVAL,KINT,KIDBRP,KLAT,KLON
INTEGER KLIST(KNELE),KFLAG(KNELE,KNVAL,KINT)
CHARACTER *9 CSTN
*
#if defined (DOC)
************************************************************************
*
* PURPOSE: TO CHECK FLAGS (FROM NAMELIST) OF (F,D) WIND COMPONENTS
* EXTRACTED FROM A BURP FILE AND TRANSFER ALL THE FLAGS
* FROM ONE ELEMENT TO THE OTHER WHEN THE FLAG IS NOT
* PRESENT IN BOTH ELEMENTS.
* THIS ASSURES THAT BOTH UU AND VV COMPONENTS WILL
* HAVE THE SAME FLAGS.
*
* NOTE THIS IS DONE ONLY INTERNALLY TO THE PROGRAM.
* THIS TRANSFER OF FLAGS DOES NOT APPEAR
* IN THE OUTPUT BURP FILES.
*
* AUTHOR: C. CHARETTE (ARMA/AES) JAN 97
*
* ARGUMENTS:
* INPUT:
* -KFLAG : DATA BLOCK OF FLAGS
* -KLIST : LIST OF ELEMENTS IN DATA BLOCK
* -KNELE : NUMBER OF ELEMENTS IN DATA BLOCK
* -KNVAL : NUMBER OF LEVELS IN DATA BLOCK
* -KINT : THIRD DIMENSION OF DATA BLOCK
* -CSTN : NAME OF STATION BEING PROCESS
* -KIDBRP : ID TYPE OF STATION
* -KLAT : LATITUDE OF STATION
* -KLON : LONGITUDE OF STATION
*
* OUTPUT:
* -MODIFIED KFLAG
*
*
************************************************************************
#endif
*
INTEGER IPROFF(JPMXNLV),IPROFD(JPMXNLV)
INTEGER JD,JJ,JN
INTEGER IND1,IND2
INTEGER IDD,IFF,IFLG,IFLGF,IFLGD
LOGICAL LLREJ, LLREJF,LLREJD
*
************************************************************************
* BURP FILE ELEMENT NAMES FOR WINDS
************************************************************************
*-------------------------------------------------------
DATA IDD,IFF/011001,011002/
*-------------------------------------------------------
*
*
************************************************************************
* GET (F,D) WIND COMPONENTS FLAGS
************************************************************************
*
DO 2 JN=1,KINT
CALL IGETELE(IFF+200000,JN,KLIST,KFLAG,IPROFF
& ,KNELE,KNVAL,KINT,IND1)
CALL IGETELE(IDD+200000,JN,KLIST,KFLAG,IPROFD
& ,KNELE,KNVAL,KINT,IND2)
*
*
IF ( (IND1 .NE. -1) .AND. (IND2 .NE. -1) )THEN
*
DO JJ=1,KNVAL
LLREJ = .FALSE.
LLREJF = .FALSE.
LLREJD = .FALSE.
DO JD = 1,NFLAGS
IFLGF = IPROFF(JJ)
IFLGD = IPROFD(JJ)
IFLG = 13 - NLISTFLG(JD)
IF(.NOT.LLREJ) THEN
LLREJF = ( BTEST(IFLGF,IFLG) ) .OR. LLREJF
LLREJD = ( BTEST(IFLGD,IFLG) ) .OR. LLREJD
IF(LLREJF) THEN
IF(.NOT.LLREJD)THEN
KFLAG(IND2,JJ,JN) = KFLAG(IND1,JJ,JN)
WRITE(NULOUT,*)
*
& ' FLAGWND: FOUND FLAG (IN NAMELIST) ON'
& ,' SPEED BUT NOT ON DIRECTION'
WRITE(NULOUT,600)CSTN,KIDBRP,KLAT,KLON,JJ
& ,NLISTFLG(JD),IPROFD(JJ),IPROFF(JJ)
*
WRITE(NULOUT,*)' AFTER TRANSFER OF FLAGS'
WRITE(NULOUT,600)CSTN,KIDBRP,KLAT,KLON,JJ
& ,NLISTFLG(JD),KFLAG(IND2,JJ,JN)
& ,KFLAG(IND1,JJ,JN)
ENDIF
LLREJ = .TRUE.
ELSEIF(LLREJD) THEN
IF(.NOT.LLREJF)THEN
KFLAG(IND1,JJ,JN) = KFLAG(IND2,JJ,JN)
*
WRITE(NULOUT,*)
& ' FLAGWND: FOUND FLAG (IN NAMELIST) ON'
& ,' DIRECTION BUT NOT ON SPEED'
WRITE(NULOUT,600)CSTN,KIDBRP,KLAT,KLON,JJ
& ,NLISTFLG(JD),IPROFD(JJ),IPROFF(JJ)
*
WRITE(NULOUT,*)' AFTER TRANSFER OF FLAGS'
WRITE(NULOUT,600)CSTN,KIDBRP,KLAT,KLON,JJ
& ,NLISTFLG(JD),KFLAG(IND2,JJ,JN)
& ,KFLAG(IND1,JJ,JN)
ENDIF
LLREJ = .TRUE.
ENDIF
ENDIF
ENDDO
ENDDO
ENDIF
2 CONTINUE
*
600 FORMAT(1X,'STN= ',A9,1X,'ID= ',I5,1X,'LAT= ',I5,1X,'LON= ',I5,1X
& ,'LEVEL= ',I4,1X,'FLG= ',I2,1X,'MKR-DIR= ',I10,1X
& ,'MKR-SPD= ',I10)
RETURN
END