!-------------------------------------- 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 VINT3DFD(elem_i,lobsSpaceData) 2,38
#if defined (DOC)
*
***s/r VINT3DFD - Computation of DIRECTION AND SPEED RESIDUALS
*
*
*Author : P. Koclas *CMC/AES September 1999
*Revision:
* 1.0 P. Koclas CMC : September 2000
* -remove quality control flag and (ff dd) component initializtions
* JM Belanger CMDA/SMC Jan 2001
* . 32 bits conversion
*
** Purpose: -Compute direction and speed residuals from u and
* v residuals.
*
*
*Arguments
*
#endif
use MathPhysConstants_mod
use obsSpaceData_mod
use bufr
IMPLICIT NONE
*implicits
*
type(struct_obs) :: lobsSpaceData
integer, intent(in) :: elem_i
INTEGER IUU,IVV,IFF,IDD
INTEGER INDEX_HEADER,ISTART,IEND,jwintyp
INTEGER INDEX_BODY,INDEX_BODY2
REAL*8 ZLEVU
REAL*8 MODUL,ANG,UU,VV
LOGICAL LLOK
C-----------------------------------------------------------------------
C
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
C
C Process all data within the domain of the model
C
BODY: DO INDEX_BODY=1,obs_numBody(lobsSpaceData)
LLOK= (obs_bodyElem_i(lobsSpaceData,OBS_ASS,INDEX_BODY) .EQ. 1)
& .AND. (obs_bodyElem_i(lobsSpaceData,OBS_VNM,INDEX_BODY) .EQ. IUU)
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
ZLEVU = obs_bodyElem_r(lobsSpaceData,OBS_PPP,INDEX_BODY)
UU=-obs_bodyElem_r(lobsSpaceData,elem_i,INDEX_BODY) +
& obs_bodyElem_r(lobsSpaceData,OBS_VAR,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
VV=-obs_bodyElem_r(lobsSpaceData,elem_i,INDEX_BODY2) +
& obs_bodyElem_r(lobsSpaceData,OBS_VAR,INDEX_BODY2)
*
*****************************************************************************
* 1-calculate angle
************************************************************************
*
MODUL=SQRT((UU**2)+(VV**2))
IF (MODUL.EQ.0.) THEN
ANG=0.0D0
ELSE
ANG=ATAN2(VV,UU)
ANG= (270.0D0 - ANG * MPC_DEGREES_PER_RADIAN_R8 )
*
************************************************************************
* 2-Change to meteorological definition of wind direction.
************************************************************************
*
IF (ANG.GT.360.0D0) ANG=ANG-360.0D0
IF (ANG.LE.0.0D0) ANG=ANG+360.0D0
ENDIF
C
ENDIF
ENDDO BODY_2
C
************************************************************************
* insert resduals into CMA
************************************************************************
C
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
call obs_bodySet_r(lobsSpaceData, elem_i, INDEX_BODY2,
& obs_bodyElem_r(lobsSpaceData,OBS_VAR,INDEX_BODY2) - ANG )
IF ( obs_bodyElem_r(lobsSpaceData,elem_i,INDEX_BODY2) .gt. 180.0d0)
& call obs_bodySet_r(lobsSpaceData, elem_i, INDEX_BODY2,
& obs_bodyElem_r(lobsSpaceData,elem_i,INDEX_BODY2)-360.0d0)
IF ( obs_bodyElem_r(lobsSpaceData,elem_i,INDEX_BODY2) .le. -180.0d0)
& call obs_bodySet_r(lobsSpaceData, elem_i, INDEX_BODY2,
& obs_bodyElem_r(lobsSpaceData,elem_i,INDEX_BODY2)+360.0d0)
call obs_bodySet_r(lobsSpaceData, elem_i, INDEX_BODY2, -1.0d0*
& obs_bodyElem_r(lobsSpaceData,elem_i,INDEX_BODY2))
call obs_bodySet_r(lobsSpaceData,OBS_OER,INDEX_BODY2,1.0d0)
call obs_bodySet_i(lobsSpaceData,OBS_ASS,INDEX_BODY2, 1)
call obs_bodySet_i(lobsSpaceData,OBS_FLG,INDEX_BODY2, 0)
ENDIF
IF ((obs_bodyElem_i(lobsSpaceData,OBS_VNM,INDEX_BODY2).EQ.IFF)
& .AND. obs_bodyElem_r(lobsSpaceData,OBS_PPP,INDEX_BODY2) .EQ. ZLEVU ) THEN
call obs_bodySet_r(lobsSpaceData,elem_i, INDEX_BODY2,
& obs_bodyElem_r(lobsSpaceData,OBS_VAR,INDEX_BODY2) - MODUL)
call obs_bodySet_r(lobsSpaceData,OBS_OER,INDEX_BODY2,1.0d0)
call obs_bodySet_i(lobsSpaceData,OBS_ASS,INDEX_BODY2, 1)
call obs_bodySet_i(lobsSpaceData,OBS_FLG,INDEX_BODY2, 0)
ENDIF
ENDDO BODY_2_2
ENDIF
ENDDO BODY
ENDDO WIND_TYPE
RETURN
END