*IF DEF,FLUXPROC FPWINDS1.2
C ******************************COPYRIGHT****************************** FPWINDS1.3
C (c) CROWN COPYRIGHT 1998, METEOROLOGICAL OFFICE, All Rights Reserved. FPWINDS1.4
C FPWINDS1.5
C Use, duplication or disclosure of this code is subject to the FPWINDS1.6
C restrictions as set forth in the contract. FPWINDS1.7
C FPWINDS1.8
C Meteorological Office FPWINDS1.9
C London Road FPWINDS1.10
C BRACKNELL FPWINDS1.11
C Berkshire UK FPWINDS1.12
C RG12 2SZ FPWINDS1.13
C FPWINDS1.14
C If no contract has been raised with this copy of the code, the use, FPWINDS1.15
C duplication or disclosure of it is strictly prohibited. Permission FPWINDS1.16
C to do so must first be obtained in writing from the Head of Numerical FPWINDS1.17
C Modelling at the above address. FPWINDS1.18
C ******************************COPYRIGHT****************************** FPWINDS1.19
C FPWINDS1.20
C Programming standard: Unified Model Documentation Paper No 3 FPWINDS1.21
C Version No 1 15/1/90 FPWINDS1.22
C History: FPWINDS1.23
C version date change FPWINDS1.24
C 4.5 03/09/98 New code FPWINDS1.25
C FPWINDS1.26
! Author: L. Gregorious FPWINDS1.27
!---------------------------------------------------------------------- FPWINDS1.28
! contains routines: winds FPWINDS1.29
! FPWINDS1.30
! Purpose: To produce a pp field containing: FPWINDS1.31
! wind stress (x-direction) FPWINDS1.32
! wind stress (y-direction) FPWINDS1.33
! wind mixing energy FPWINDS1.34
! for all the fields required. FPWINDS1.35
! Addition of rotated grid (S. Spall) FPWINDS1.36
!---------------------------------------------------------------------- FPWINDS1.37
subroutine winds( 1,7FPWINDS1.38
*CALL AFIELDS 
FPWINDS1.39
*CALL ARGPPX FPWINDS1.40
# icode ) FPWINDS1.41
FPWINDS1.42
implicit none FPWINDS1.43
FPWINDS1.44
! declaration of argument list FPWINDS1.45
FPWINDS1.46
! array dimensions, lsms, interpolation coeffs etc. : all intent IN FPWINDS1.47
*CALL CFIELDS FPWINDS1.48
FPWINDS1.49
integer icode ! IN/OUT error code ; > 0 => fatal error detected FPWINDS1.50
FPWINDS1.51
! declaration of parameters FPWINDS1.52
*CALL CSUBMODL FPWINDS1.53
*CALL CPPXREF FPWINDS1.54
*CALL PPXLOOK FPWINDS1.55
*CALL CFDCODES FPWINDS1.56
*CALL PLOOKUPS FPWINDS1.57
FPWINDS1.58
! declaration of globals used FPWINDS1.59
*CALL CUNITNOS FPWINDS1.60
*CALL CMESS FPWINDS1.61
*CALL CVALOFF FPWINDS1.62
*CALL CDEBUG FPWINDS1.63
FPWINDS1.64
FPWINDS1.65
! declaration of local arrays FPWINDS1.66
integer Int_Head_taux(Len_IntHd) ! integer part of lookup table FPWINDS1.67
integer Int_Head_tauy(Len_IntHd) ! integer part of lookup table FPWINDS1.68
integer Int_Head_WME(Len_IntHd) ! integer part of lookup table FPWINDS1.69
real Real_Head_taux(Len_RealHd) ! real part of lookup table FPWINDS1.70
real Real_Head_tauy(Len_RealHd) ! real part of lookup table FPWINDS1.71
real Real_Head_WME(Len_RealHd) ! real part of lookup table FPWINDS1.72
real windstressu(ncols, nrowsu) ! wind stress fields (taux) FPWINDS1.73
real windstressv(ncols, nrowsu) ! wind stress fields (tauy) FPWINDS1.74
real wind_mixing_energy(ncols,nrowst) ! wind mixing energy FPWINDS1.75
real wndu_tmp(ncols, nrowsu) ! wind stress on reg. lat-long grid FPWINDS1.76
real wndv_tmp(ncols, nrowsu) ! wind stress on reg. lat-long grid FPWINDS1.77
FPWINDS1.78
! declaration of local scalars FPWINDS1.79
FPWINDS1.80
integer ivt ! loop index over validity times FPWINDS1.81
integer IVTOffHr ! offset of validity time from reference FPWINDS1.82
integer IOutUnit ! output unit FPWINDS1.83
FPWINDS1.84
integer i ! loop index for columns FPWINDS1.85
integer j ! loop index for rows FPWINDS1.86
FPWINDS1.87
logical ldebug ! T => output debugging info (set in 0.) FPWINDS1.88
logical l_leads ! T => using minleadsfrac FPWINDS1.89
! F => using minicefrac FPWINDS1.90
FPWINDS1.91
! declaration of externals FPWINDS1.92
external write_one_field FPWINDS1.93
FPWINDS1.94
!---------------------------------------------------------------------- FPWINDS1.95
! 0. Preliminaries FPWINDS1.96
!---------------------------------------------------------------------- FPWINDS1.97
CSub = 'winds' ! subroutine name for error messages FPWINDS1.98
FPWINDS1.99
ldebug = l_winds_dbg ! set by debug input control file FPWINDS1.100
FPWINDS1.101
!---------------------------------------------------------------------- FPWINDS1.102
! 1. start loop over validity times FPWINDS1.103
!---------------------------------------------------------------------- FPWINDS1.104
do ivt = 1, NoValidTimes FPWINDS1.105
FPWINDS1.106
IVTOffHr = IValidOffHr(ivt) FPWINDS1.107
IOutUnit = IOutUnitOff(ivt) + UnitWindsOut FPWINDS1.108
FPWINDS1.109
!---------------------------------------------------------------------- FPWINDS1.110
! 2.1 read in windstresses FPWINDS1.111
!---------------------------------------------------------------------- FPWINDS1.112
FPWINDS1.113
call read_vector_flds (StCWindStressU,StCWindStressV, FPWINDS1.114
# IVTOffHr, ldebug, FPWINDS1.115
# Int_Head_taux, Int_Head_tauy, FPWINDS1.116
# Real_Head_taux, Real_Head_tauy,ncols, nrowsu, FPWINDS1.117
# windstressu, windstressv, FPWINDS1.118
*CALL ARGPPX FPWINDS1.119
# icode) FPWINDS1.120
FPWINDS1.121
if ( icode .gt. 0 ) then FPWINDS1.122
write(UnErr,*)CErr,CSub, FPWINDS1.123
# ' step 2.1 unable to read windstresses' FPWINDS1.124
icode = 1006 FPWINDS1.125
go to 9999 FPWINDS1.126
end if FPWINDS1.127
FPWINDS1.128
!---------------------------------------------------------------------- FPWINDS1.129
! 2.2 Rotate wind vectors if rotated grids are used FPWINDS1.130
!---------------------------------------------------------------------- FPWINDS1.131
FPWINDS1.132
if (rotg) then FPWINDS1.133
call w_eqtoll(coef_angle1, coef_angle2, windstressu, FPWINDS1.134
# windstressv, wndu_tmp, wndv_tmp, ncols*nrowsu, FPWINDS1.135
# ncols*nrowsu) FPWINDS1.136
else FPWINDS1.137
do j = 1, nrowsu FPWINDS1.138
do i = 1, ncols FPWINDS1.139
wndu_tmp(i,j)=windstressu(i,j) FPWINDS1.140
wndv_tmp(i,j)=windstressv(i,j) FPWINDS1.141
enddo FPWINDS1.142
enddo FPWINDS1.143
endif FPWINDS1.144
FPWINDS1.145
if (rotgO) then FPWINDS1.146
call w_lltoeq(coef_angle3, coef_angle4, wndu_tmp, FPWINDS1.147
# wndv_tmp, windstressu, windstressv, ncols*nrowsu, FPWINDS1.148
# ncols*nrowsu) FPWINDS1.149
else FPWINDS1.150
do j = 1, nrowsu FPWINDS1.151
do i = 1, ncols FPWINDS1.152
windstressu(i,j)=wndu_tmp(i,j) FPWINDS1.153
windstressv(i,j)=wndv_tmp(i,j) FPWINDS1.154
enddo FPWINDS1.155
enddo FPWINDS1.156
endif FPWINDS1.157
FPWINDS1.158
!---------------------------------------------------------------------- FPWINDS1.159
! 2.3 write out U + V component of windstress FPWINDS1.160
!---------------------------------------------------------------------- FPWINDS1.161
FPWINDS1.162
call write_one_field ( FPWINDS1.163
*CALL AFIELDS FPWINDS1.164
# OutStCTAUX, FFTAUX, PPTAUX, IVTOffHr, FPWINDS1.165
# Int_Head_taux, Real_Head_taux, IOutUnit, FPWINDS1.166
# ldebug, IUGrid, nrowsu, FPWINDS1.167
# windstressu, icode) FPWINDS1.168
if ( icode .gt. 0 ) then FPWINDS1.169
write(UnErr,*)CErr,CSub, FPWINDS1.170
# ' step 2.2 unable to write U component of windstresses' FPWINDS1.171
icode = 1103 FPWINDS1.172
go to 9999 FPWINDS1.173
end if FPWINDS1.174
call write_one_field ( FPWINDS1.175
*CALL AFIELDS FPWINDS1.176
# OutStCTAUY, FFTAUY, PPTAUY, IVTOffHr, FPWINDS1.177
# Int_Head_tauy, Real_Head_tauy, IOutUnit, FPWINDS1.178
# ldebug, IUGrid, nrowsu, FPWINDS1.179
# windstressv, icode) FPWINDS1.180
FPWINDS1.181
if ( icode .gt. 0 ) then FPWINDS1.182
write(UnErr,*)CErr,CSub, FPWINDS1.183
# ' step 2. unable to write V component of windstresses' FPWINDS1.184
icode = 1104 FPWINDS1.185
go to 9999 FPWINDS1.186
end if FPWINDS1.187
FPWINDS1.188
!---------------------------------------------------------------------- FPWINDS1.189
! 3. Read in wind mixing energy FPWINDS1.190
!---------------------------------------------------------------------- FPWINDS1.191
l_leads = .true. ! set to use minleadsfrac FPWINDS1.192
call read_leads_flds(StCWindMixEng, StCAICE, FPWINDS1.193
# IVTOffHr, ldebug, FPWINDS1.194
# l_leads,Int_Head_WME, FPWINDS1.195
# Real_Head_WME, ncols, nrowst, FPWINDS1.196
# wind_mixing_energy, FPWINDS1.197
*CALL ARGPPX FPWINDS1.198
# icode) FPWINDS1.199
FPWINDS1.200
if ( icode .gt. 0 ) then FPWINDS1.201
write(UnErr,*)CErr,CSub, FPWINDS1.202
# ' step 3. unable to read Wind Mixing Energy' FPWINDS1.203
icode = 1007 FPWINDS1.204
go to 9999 FPWINDS1.205
end if FPWINDS1.206
FPWINDS1.207
!---------------------------------------------------------------------- FPWINDS1.208
! 3.1 Write out wind mixing energy FPWINDS1.209
!---------------------------------------------------------------------- FPWINDS1.210
call write_one_field ( FPWINDS1.211
*CALL AFIELDS FPWINDS1.212
# OutStCWME, FFWME, PPWME, IVTOffHr, FPWINDS1.213
# Int_Head_WME, Real_Head_WME, IOutUnit, FPWINDS1.214
# ldebug, ITGrid, nrowst, FPWINDS1.215
# wind_mixing_energy, icode) FPWINDS1.216
if ( icode .gt. 0 ) then FPWINDS1.217
write(UnErr,*)CErr,CSub, FPWINDS1.218
# ' step 3.1. unable to write wind mixing energy' FPWINDS1.219
icode = 1105 FPWINDS1.220
go to 9999 FPWINDS1.221
end if FPWINDS1.222
FPWINDS1.223
!---------------------------------------------------------------------- FPWINDS1.224
! Last. end loop over validity times FPWINDS1.225
!---------------------------------------------------------------------- FPWINDS1.226
enddo ! ivt FPWINDS1.227
FPWINDS1.228
9999 continue FPWINDS1.229
return FPWINDS1.230
end FPWINDS1.231
!---------------------------------------------------------------------- FPWINDS1.232
*ENDIF FPWINDS1.233