*IF DEF,FLUXPROC FPWNDSPD.2
C ******************************COPYRIGHT****************************** FPWNDSPD.3
C (c) CROWN COPYRIGHT 1998, METEOROLOGICAL OFFICE, All Rights Reserved. FPWNDSPD.4
C FPWNDSPD.5
C Use, duplication or disclosure of this code is subject to the FPWNDSPD.6
C restrictions as set forth in the contract. FPWNDSPD.7
C FPWNDSPD.8
C Meteorological Office FPWNDSPD.9
C London Road FPWNDSPD.10
C BRACKNELL FPWNDSPD.11
C Berkshire UK FPWNDSPD.12
C RG12 2SZ FPWNDSPD.13
C FPWNDSPD.14
C If no contract has been raised with this copy of the code, the use, FPWNDSPD.15
C duplication or disclosure of it is strictly prohibited. Permission FPWNDSPD.16
C to do so must first be obtained in writing from the Head of Numerical FPWNDSPD.17
C Modelling at the above address. FPWNDSPD.18
C ******************************COPYRIGHT****************************** FPWNDSPD.19
C FPWNDSPD.20
C Programming standard: Unified Model Documentation Paper No 3 FPWNDSPD.21
C Version No 1 15/1/90 FPWNDSPD.22
C History: FPWNDSPD.23
C version date change FPWNDSPD.24
C 4.5 03/09/98 New code FPWNDSPD.25
C FPWNDSPD.26
! Author: S. A. Spall FPWNDSPD.27
!---------------------------------------------------------------------- FPWNDSPD.28
! contains routines: windspeed FPWNDSPD.29
! FPWNDSPD.30
! Purpose: Flux processing routine. FPWNDSPD.31
! To produce a pp field containing: FPWNDSPD.32
! wind speed (x-direction) FPWNDSPD.33
! wind speed (y-direction) FPWNDSPD.34
! for all the fields required FPWNDSPD.35
!---------------------------------------------------------------------- FPWNDSPD.36
subroutine windspd( 1,5FPWNDSPD.37
*CALL AFIELDS 
FPWNDSPD.38
*CALL ARGPPX FPWNDSPD.39
# icode ) FPWNDSPD.40
FPWNDSPD.41
implicit none FPWNDSPD.42
FPWNDSPD.43
! declaration of argument list FPWNDSPD.44
FPWNDSPD.45
! array dimensions, lsms, interpolation coeffs etc. : all intent IN FPWNDSPD.46
*CALL CFIELDS FPWNDSPD.47
FPWNDSPD.48
integer icode ! IN/OUT error code ; > 0 => fatal error detected FPWNDSPD.49
FPWNDSPD.50
! declaration of parameters FPWNDSPD.51
*CALL CSUBMODL FPWNDSPD.52
*CALL CPPXREF FPWNDSPD.53
*CALL PPXLOOK FPWNDSPD.54
*CALL CFDCODES FPWNDSPD.55
*CALL PLOOKUPS FPWNDSPD.56
FPWNDSPD.57
! declaration of globals used FPWNDSPD.58
*CALL CUNITNOS FPWNDSPD.59
*CALL CMESS FPWNDSPD.60
*CALL CVALOFF FPWNDSPD.61
*CALL CDEBUG FPWNDSPD.62
FPWNDSPD.63
FPWNDSPD.64
! declaration of local arrays FPWNDSPD.65
integer Int_Head_wspx(Len_IntHd) ! integer part of lookup table FPWNDSPD.66
integer Int_Head_wspy(Len_IntHd) ! integer part of lookup table FPWNDSPD.67
real Real_Head_wspx(Len_RealHd) ! real part of lookup table FPWNDSPD.68
real Real_Head_wspy(Len_RealHd) ! real part of lookup table FPWNDSPD.69
real windspeedu(ncols, nrowsu) ! wind speed fields FPWNDSPD.70
real windspeedv(ncols, nrowsu) ! wind speed fields FPWNDSPD.71
real wndu_tmp(ncols, nrowsu) ! wind speed on reg. lat-long grid FPWNDSPD.72
real wndv_tmp(ncols, nrowsu) ! wind speed on reg. lat-long grid FPWNDSPD.73
FPWNDSPD.74
! declaration of local scalars FPWNDSPD.75
FPWNDSPD.76
integer ivt ! loop index over validity times FPWNDSPD.77
integer IVTOffHr ! offset of validity time from reference FPWNDSPD.78
integer IOutUnit ! output unit FPWNDSPD.79
FPWNDSPD.80
integer i ! loop index for columns FPWNDSPD.81
integer j ! loop index for rows FPWNDSPD.82
FPWNDSPD.83
logical ldebug ! T => output debugging info (set in 0.) FPWNDSPD.84
FPWNDSPD.85
! declaration of externals FPWNDSPD.86
external write_one_field FPWNDSPD.87
FPWNDSPD.88
!---------------------------------------------------------------------- FPWNDSPD.89
! 0. Preliminaries FPWNDSPD.90
!---------------------------------------------------------------------- FPWNDSPD.91
CSub = 'windspeed' ! subroutine name for error messages FPWNDSPD.92
FPWNDSPD.93
ldebug = l_windspd_dbg ! set by debug input control file FPWNDSPD.94
FPWNDSPD.95
!---------------------------------------------------------------------- FPWNDSPD.96
! 1. start loop over validity times FPWNDSPD.97
!---------------------------------------------------------------------- FPWNDSPD.98
do ivt = 1, NoValidTimes FPWNDSPD.99
FPWNDSPD.100
IVTOffHr = IValidOffHr(ivt) FPWNDSPD.101
IOutUnit = IOutUnitOff(ivt) + UnitWindspdOut FPWNDSPD.102
FPWNDSPD.103
!---------------------------------------------------------------------- FPWNDSPD.104
! 2.1 read in wind speeds FPWNDSPD.105
!---------------------------------------------------------------------- FPWNDSPD.106
FPWNDSPD.107
call read_vector_flds (StCWindSpeedU,StCWindSpeedV, FPWNDSPD.108
# IVTOffHr, ldebug, FPWNDSPD.109
# Int_Head_wspx, Int_Head_wspy, FPWNDSPD.110
# Real_Head_wspx, Real_Head_wspy,ncols, nrowsu, FPWNDSPD.111
# windspeedu, windspeedv, FPWNDSPD.112
*CALL ARGPPX FPWNDSPD.113
# icode) FPWNDSPD.114
FPWNDSPD.115
if ( icode .gt. 0 ) then FPWNDSPD.116
write(UnErr,*)CErr,CSub, FPWNDSPD.117
# ' step 2.1 unable to read wind speeds' FPWNDSPD.118
icode = 1006 FPWNDSPD.119
go to 9999 FPWNDSPD.120
end if FPWNDSPD.121
FPWNDSPD.122
!---------------------------------------------------------------------- FPWNDSPD.123
! 2.2 Rotate wind vectors if rotated grids are used FPWNDSPD.124
!---------------------------------------------------------------------- FPWNDSPD.125
FPWNDSPD.126
if (rotg) then FPWNDSPD.127
call w_eqtoll(coef_angle1, coef_angle2, windspeedu, FPWNDSPD.128
# windspeedv, wndu_tmp, wndv_tmp, ncols*nrowsu, FPWNDSPD.129
# ncols*nrowsu) FPWNDSPD.130
else FPWNDSPD.131
do j = 1, nrowsu FPWNDSPD.132
do i = 1, ncols FPWNDSPD.133
wndu_tmp(i,j)=windspeedu(i,j) FPWNDSPD.134
wndv_tmp(i,j)=windspeedv(i,j) FPWNDSPD.135
enddo FPWNDSPD.136
enddo FPWNDSPD.137
endif FPWNDSPD.138
FPWNDSPD.139
if (rotgO) then FPWNDSPD.140
call w_lltoeq(coef_angle3, coef_angle4, wndu_tmp, FPWNDSPD.141
# wndv_tmp, windspeedu, windspeedv, ncols*nrowsu, FPWNDSPD.142
# ncols*nrowsu) FPWNDSPD.143
else FPWNDSPD.144
do j = 1, nrowsu FPWNDSPD.145
do i = 1, ncols FPWNDSPD.146
windspeedu(i,j)=wndu_tmp(i,j) FPWNDSPD.147
windspeedv(i,j)=wndv_tmp(i,j) FPWNDSPD.148
enddo FPWNDSPD.149
enddo FPWNDSPD.150
endif FPWNDSPD.151
FPWNDSPD.152
!---------------------------------------------------------------------- FPWNDSPD.153
! 2.3 write out U + V component of wind speed FPWNDSPD.154
!---------------------------------------------------------------------- FPWNDSPD.155
FPWNDSPD.156
call write_one_field ( FPWNDSPD.157
*CALL AFIELDS FPWNDSPD.158
# OutStCWSPX, FFWSPX, PPWSPX, IVTOffHr, FPWNDSPD.159
# Int_Head_wspx, Real_Head_wspx, IOutUnit, FPWNDSPD.160
# ldebug, IUGrid, nrowsu, FPWNDSPD.161
# windspeedu, icode) FPWNDSPD.162
if ( icode .gt. 0 ) then FPWNDSPD.163
write(UnErr,*)CErr,CSub, FPWNDSPD.164
# ' step 2.2 unable to write U component of wind speed' FPWNDSPD.165
icode = 1103 FPWNDSPD.166
go to 9999 FPWNDSPD.167
end if FPWNDSPD.168
call write_one_field ( FPWNDSPD.169
*CALL AFIELDS FPWNDSPD.170
# OutStCWSPY, FFWSPY, PPWSPY, IVTOffHr, FPWNDSPD.171
# Int_Head_wspy, Real_Head_wspy, IOutUnit, FPWNDSPD.172
# ldebug, IUGrid, nrowsu, FPWNDSPD.173
# windspeedv, icode) FPWNDSPD.174
FPWNDSPD.175
if ( icode .gt. 0 ) then FPWNDSPD.176
write(UnErr,*)CErr,CSub, FPWNDSPD.177
# ' step 2. unable to write V component of wind speed' FPWNDSPD.178
icode = 1104 FPWNDSPD.179
go to 9999 FPWNDSPD.180
end if FPWNDSPD.181
FPWNDSPD.182
!---------------------------------------------------------------------- FPWNDSPD.183
! Last. end loop over validity times FPWNDSPD.184
!---------------------------------------------------------------------- FPWNDSPD.185
enddo ! ivt FPWNDSPD.186
FPWNDSPD.187
9999 continue FPWNDSPD.188
return FPWNDSPD.189
end FPWNDSPD.190
!---------------------------------------------------------------------- FPWNDSPD.191
*ENDIF FPWNDSPD.192