*IF DEF,A13_1C FILTUV1C.2
C ******************************COPYRIGHT****************************** FILTUV1C.3
C (c) CROWN COPYRIGHT 1997, METEOROLOGICAL OFFICE, All Rights Reserved. FILTUV1C.4
C FILTUV1C.5
C Use, duplication or disclosure of this code is subject to the FILTUV1C.6
C restrictions as set forth in the contract. FILTUV1C.7
C FILTUV1C.8
C Meteorological Office FILTUV1C.9
C London Road FILTUV1C.10
C BRACKNELL FILTUV1C.11
C Berkshire UK FILTUV1C.12
C RG12 2SZ FILTUV1C.13
C FILTUV1C.14
C If no contract has been raised with this copy of the code, the use, FILTUV1C.15
C duplication or disclosure of it is strictly prohibited. Permission FILTUV1C.16
C to do so must first be obtained in writing from the Head of Numerical FILTUV1C.17
C Modelling at the above address. FILTUV1C.18
C ******************************COPYRIGHT****************************** FILTUV1C.19
C FILTUV1C.20
CLL SUBROUTINE FILT_UV ------------------------------------------ FILTUV1C.21
CLL FILTUV1C.22
CLL PURPOSE: PERFORMS MASS-WEIGHTED FILTERING AND POLAR AVERAGING OF FILTUV1C.23
CLL U AND V FIELDS. FILTUV1C.24
CLL NOT SUITABLE FOR SINGLE COLUMN USE. FILTUV1C.25
CLL FILTUV1C.26
CLL WRITTEN BY M.H MAWSON. FILTUV1C.27
CLL FILTUV1C.28
CLL MODEL MODIFICATION HISTORY: FILTUV1C.29
CLL VERSION DATE FILTUV1C.30
!LL 4.4 11/08/97 New version optimised for T3E. FILTUV1C.31
!LL Not bit-reproducible with FILTUV1A. FILTUV1C.32
CLL 4.4 14/07/97 Simplify calculation of RS*DELTAP for efficiency. FILTUV1C.33
CLL A.Dickinson FILTUV1C.34
CLL FILTUV1C.35
CLL PROGRAMMING STANDARD: FILTUV1C.36
CLL FILTUV1C.37
CLL SYSTEM COMPONENTS COVERED: P142 FILTUV1C.38
CLL SYSTEM TASK: P1 FILTUV1C.39
CLL DOCUMENTATION: SECTION 3.5 FILTUV1C.40
CLL IN UNIFIED MODEL DOCUMENTATION PAPER FILTUV1C.41
CLL NO. 10 M.J.P. CULLEN,T.DAVIES AND M.H.MAWSON FILTUV1C.42
CLL VERSION 8, DATED 10/09/90. FILTUV1C.43
CLLEND------------------------------------------------------------- FILTUV1C.44
FILTUV1C.45
C*L ARGUMENTS:--------------------------------------------------- FILTUV1C.46
SUBROUTINE FILT_UV 1,8FILTUV1C.47
1 (PSTAR,U,V,RS_FUNCTIONS,DELTA_AK,DELTA_BK, FILTUV1C.48
2 P_FIELD,U_FIELD,NORTHERN_FILTERED_P_ROW, FILTUV1C.49
3 SOUTHERN_FILTERED_P_ROW,P_LEVELS, FILTUV1C.50
4 ROW_LENGTH, FILTUV1C.51
*CALL ARGFLDPT 
FILTUV1C.52
& TRIGS,IFAX, FILTUV1C.53
4 COS_LONGITUDE,SIN_LONGITUDE, FILTUV1C.54
5 FILTER_WAVE_NUMBER_U_ROWS) FILTUV1C.55
FILTUV1C.56
IMPLICIT NONE FILTUV1C.57
FILTUV1C.58
INTEGER FILTUV1C.59
* U_FIELD !IN DIMENSION OF FIELDS ON VELOCITY GRID FILTUV1C.60
*, P_FIELD !IN DIMENSION OF FIELDS ON PRESSURE GRID FILTUV1C.61
*, P_LEVELS !IN NUMBER OF MODEL LEVELS. FILTUV1C.62
*, ROW_LENGTH !IN NUMBER OF POINTS PER ROW FILTUV1C.63
*, NORTHERN_FILTERED_P_ROW !IN ROW ON WHICH FILTERING STOPS FILTUV1C.64
* ! MOVING TOWARDS EQUATOR. FILTUV1C.65
*, SOUTHERN_FILTERED_P_ROW !IN ROW ON WHICH FILTERING STARTS AGAIN FILTUV1C.66
* ! MOVING TOWARDS SOUTH POLE. FILTUV1C.67
*, IFAX(10) !IN HOLDS FACTORS OF ROW_LENGTH USED BY FILTUV1C.68
* ! FILTERING. FILTUV1C.69
FILTUV1C.70
! All TYPFLDPT arguments are intent IN FILTUV1C.71
*CALL TYPFLDPT FILTUV1C.72
FILTUV1C.73
INTEGER FILTUV1C.74
& FILTER_WAVE_NUMBER_U_ROWS(GLOBAL_U_FIELD/GLOBAL_ROW_LENGTH) FILTUV1C.75
! LAST WAVE NUMBER NOT TO BE CHOPPED FILTUV1C.76
REAL FILTUV1C.77
* U(U_FIELD,P_LEVELS) !INOUT U VELOCITY FIELD. FILTUV1C.78
*,V(U_FIELD,P_LEVELS) !INOUT V VELOCITY FIELD. FILTUV1C.79
FILTUV1C.80
REAL FILTUV1C.81
* PSTAR(P_FIELD) !IN PSTAR FIELD. FILTUV1C.82
*,RS_FUNCTIONS(P_FIELD,P_LEVELS) !IN RS FILTUV1C.83
*,DELTA_AK(P_LEVELS) !IN LAYER THICKNESS FILTUV1C.84
*,DELTA_BK(P_LEVELS) !IN LAYER THICKNESS FILTUV1C.85
*,TRIGS(ROW_LENGTH) !IN HOLDS TRIGONOMETRIC FUNCTIONS FILTUV1C.86
* ! USED IN FILTERING. FILTUV1C.87
*,COS_LONGITUDE(ROW_LENGTH) !IN COSINE LONGITUDE AT U POINTS FILTUV1C.88
*,SIN_LONGITUDE(ROW_LENGTH) !IN SINE LONGITUDE AT U POINTS FILTUV1C.89
C*--------------------------------------------------------------------- FILTUV1C.90
FILTUV1C.91
C*L DEFINE ARRAYS AND VARIABLES USED IN THIS ROUTINE----------------- FILTUV1C.92
C DEFINE LOCAL ARRAYS: 1 IS REQUIRED FILTUV1C.93
REAL FILTUV1C.94
* WORK(P_FIELD) ! GENERAL WORKSPACE. FILTUV1C.95
FILTUV1C.96
C*--------------------------------------------------------------------- FILTUV1C.97
C DEFINE LOCAL VARIABLES FILTUV1C.98
FILTUV1C.99
C REAL SCALARS FILTUV1C.100
REAL FILTUV1C.101
* SCALAR3 FILTUV1C.102
FILTUV1C.103
C COUNT VARIABLES FOR DO LOOPS ETC. FILTUV1C.104
INTEGER FILTUV1C.105
* I,K FILTUV1C.106
*, NORTHERN_FILTERED_U_ROW ! U ROW ON WHICH FILTERING STOPS FILTUV1C.107
*, SOUTHERN_FILTERED_U_ROW ! U ROW ON WHICH FILTERING STARTS AGAIN FILTUV1C.108
*, FILTER_SPACE ! HORIZONTAL DIMENSION OF SPACE NEEDED IN FILTERING FILTUV1C.109
* ! ROUTINE. FILTUV1C.110
FILTUV1C.111
C*L EXTERNAL SUBROUTINE CALLS:--------------------------------------- FILTUV1C.112
EXTERNAL FILTUV1C.113
* P_TO_UV,FILTER,POLAR_UV FILTUV1C.114
C*--------------------------------------------------------------------- FILTUV1C.115
CL MAXIMUM VECTOR LENGTH ASSUMED IS P_FIELD FILTUV1C.116
CL--------------------------------------------------------------------- FILTUV1C.117
CL INTERNAL STRUCTURE. FILTUV1C.118
CL--------------------------------------------------------------------- FILTUV1C.119
CL FILTUV1C.120
CL--------------------------------------------------------------------- FILTUV1C.121
CL SECTION 1. MASS-WEIGHT U AND V FIELDS. FILTUV1C.122
CL--------------------------------------------------------------------- FILTUV1C.123
FILTUV1C.124
! QAN fix : blank out WORK array so halos don't contain junk FILTUV1C.125
DO I=1,P_FIELD FILTUV1C.126
WORK(I)=0.0 FILTUV1C.127
ENDDO FILTUV1C.128
FILTUV1C.129
CL LOOP OVER P_LEVELS. FILTUV1C.130
FILTUV1C.131
DO 100 K=1,P_LEVELS FILTUV1C.132
FILTUV1C.133
CL CALCULATE RS*DELTA P FILTUV1C.134
DO I=FIRST_VALID_PT,LAST_P_VALID_PT FILTUV1C.135
WORK(I) = RS_FUNCTIONS(I,K) FILTUV1C.136
& * (DELTA_AK(K) + DELTA_BK(K)*PSTAR(I)) FILTUV1C.137
END DO FILTUV1C.138
FILTUV1C.139
FILTUV1C.140
CL CALL P_TO_UV TO TRANSFER RS*DELTA P TO U GRID. FILTUV1C.141
FILTUV1C.142
CALL P_TO_UV(WORK,RS_FUNCTIONS(1,K),P_FIELD,U_FIELD,ROW_LENGTH, FILTUV1C.143
& tot_P_ROWS) FILTUV1C.144
FILTUV1C.145
CL MASS WEIGHT U AND V FIELDS. FILTUV1C.146
FILTUV1C.147
DO 120 I=FIRST_VALID_PT,LAST_U_VALID_PT FILTUV1C.148
U(I,K) = U(I,K) * RS_FUNCTIONS(I,K) FILTUV1C.149
V(I,K) = V(I,K) * RS_FUNCTIONS(I,K) FILTUV1C.150
120 CONTINUE FILTUV1C.151
FILTUV1C.152
CL END LOOP OVER P_LEVELS. FILTUV1C.153
100 CONTINUE FILTUV1C.154
FILTUV1C.155
CL FILTUV1C.156
CL--------------------------------------------------------------------- FILTUV1C.157
CL SECTION 2. CALL FILTER TO FILTER FIELDS. FILTUV1C.158
CL--------------------------------------------------------------------- FILTUV1C.159
FILTUV1C.160
C SET NORTHERN AND SOUTHERN ROWS FOR U FILTERING. FILTUV1C.161
FILTUV1C.162
NORTHERN_FILTERED_U_ROW = NORTHERN_FILTERED_P_ROW FILTUV1C.163
SOUTHERN_FILTERED_U_ROW = SOUTHERN_FILTERED_P_ROW - 1 FILTUV1C.164
FILTUV1C.165
C SET FILTER_SPACE WHICH IS ROW_LENGTH+2 TIMES THE NUMBER OF ROWS TO FILTUV1C.166
C BE FILTERED. FILTUV1C.167
FILTUV1C.168
FILTER_SPACE = (ROW_LENGTH+2)*(NORTHERN_FILTERED_U_ROW-1+ FILTUV1C.169
* U_FIELD/ROW_LENGTH-SOUTHERN_FILTERED_U_ROW) FILTUV1C.170
FILTUV1C.171
CL CALL FILTER FOR U FILTUV1C.172
FILTUV1C.173
CALL FILTER(U,U_FIELD,P_LEVELS,FILTER_SPACE,ROW_LENGTH, FILTUV1C.174
*CALL ARGFLDPT FILTUV1C.175
* FILTER_WAVE_NUMBER_U_ROWS,TRIGS,IFAX, FILTUV1C.176
* NORTHERN_FILTERED_U_ROW,SOUTHERN_FILTERED_U_ROW) FILTUV1C.177
FILTUV1C.178
CL CALL FILTER FOR V FILTUV1C.179
FILTUV1C.180
CALL FILTER(V,U_FIELD,P_LEVELS,FILTER_SPACE,ROW_LENGTH, FILTUV1C.181
*CALL ARGFLDPT FILTUV1C.182
* FILTER_WAVE_NUMBER_U_ROWS,TRIGS,IFAX, FILTUV1C.183
* NORTHERN_FILTERED_U_ROW,SOUTHERN_FILTERED_U_ROW) FILTUV1C.184
FILTUV1C.185
CL FILTUV1C.186
CL--------------------------------------------------------------------- FILTUV1C.187
CL SECTION 3. REMOVE MASS-WEIGHTING FROM U AND V. FILTUV1C.188
CL--------------------------------------------------------------------- FILTUV1C.189
FILTUV1C.190
FILTUV1C.191
! CALL POLAR_UV TO UPDATE THE POLAR VALUES OF MASS-WEIGHTED U AND V FILTUV1C.192
FILTUV1C.193
CALL POLAR_UV(U,V,ROW_LENGTH,U_FIELD,P_LEVELS, FILTUV1C.194
*CALL ARGFLDPT FILTUV1C.195
& COS_LONGITUDE,SIN_LONGITUDE) FILTUV1C.196
CL LOOP OVER P_LEVELS. FILTUV1C.197
FILTUV1C.198
DO 300 K=1,P_LEVELS FILTUV1C.199
FILTUV1C.200
FILTUV1C.201
CL REMOVE MASS-WEIGHTING. FILTUV1C.202
FILTUV1C.203
CFPP$ SELECT(CONCUR) FILTUV1C.204
DO 310 I=FIRST_VALID_PT,LAST_U_VALID_PT FILTUV1C.205
SCALAR3 = 1./RS_FUNCTIONS(I,K) FILTUV1C.206
U(I,K) = U(I,K) * SCALAR3 FILTUV1C.207
V(I,K) = V(I,K) * SCALAR3 FILTUV1C.208
310 CONTINUE FILTUV1C.209
FILTUV1C.210
CL END LOOP OVER P_LEVELS FILTUV1C.211
FILTUV1C.212
300 CONTINUE FILTUV1C.213
FILTUV1C.214
CL END OF ROUTINE FILT_UV FILTUV1C.215
FILTUV1C.216
RETURN FILTUV1C.217
END FILTUV1C.218
*ENDIF FILTUV1C.219