*IF DEF,A13_1A,OR,DEF,A13_1B ATJ0F402.27
C ******************************COPYRIGHT****************************** GTS2F400.2863
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.2864
C GTS2F400.2865
C Use, duplication or disclosure of this code is subject to the GTS2F400.2866
C restrictions as set forth in the contract. GTS2F400.2867
C GTS2F400.2868
C Meteorological Office GTS2F400.2869
C London Road GTS2F400.2870
C BRACKNELL GTS2F400.2871
C Berkshire UK GTS2F400.2872
C RG12 2SZ GTS2F400.2873
C GTS2F400.2874
C If no contract has been raised with this copy of the code, the use, GTS2F400.2875
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.2876
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.2877
C Modelling at the above address. GTS2F400.2878
C ******************************COPYRIGHT****************************** GTS2F400.2879
C GTS2F400.2880
CLL SUBROUTINE FILT_UV ------------------------------------------ FILTUV1A.3
CLL FILTUV1A.4
CLL PURPOSE: PERFORMS MASS-WEIGHTED FILTERING AND POLAR AVERAGING OF FILTUV1A.5
CLL U AND V FIELDS. FILTUV1A.6
CLL NOT SUITABLE FOR SINGLE COLUMN USE. FILTUV1A.7
CLL FILTUV1A.8
CLL WRITTEN BY M.H MAWSON. FILTUV1A.9
CLL FILTUV1A.10
CLL MODEL MODIFICATION HISTORY FROM MODEL VERSION 3.0: FILTUV1A.11
CLL VERSION DATE FILTUV1A.12
! 4.1 30/06/95 Minor change to P_TO_UV for MPP version and APB7F401.124
! added TYPFLDPT arguments APB7F401.125
! P.Burton APB7F401.126
!LL 4.2 16/08/96 Added TYPLDPT variables. APB0F402.81
!LL Made FILTER_WAVE_NUMBER_U_ROWS globally sized. APB0F402.82
!LL P.Burton APB0F402.83
C vn4.3 Mar. 97 T3E migration: optimisation changes GSS1F403.419
C S.J.Swarbrick GSS1F403.420
CLL FILTUV1A.13
CLL PROGRAMMING STANDARD: UNIFIED MODEL DOCUMENTATION PAPER NO. 4, FILTUV1A.14
CLL STANDARD B. VERSION 2, DATED 18/01/90 FILTUV1A.15
CLL SYSTEM COMPONENTS COVERED: P142 FILTUV1A.16
CLL SYSTEM TASK: P1 FILTUV1A.17
CLL DOCUMENTATION: SECTION 3.5 FILTUV1A.18
CLL IN UNIFIED MODEL DOCUMENTATION PAPER FILTUV1A.19
CLL NO. 10 M.J.P. CULLEN,T.DAVIES AND M.H.MAWSON FILTUV1A.20
CLL VERSION 8, DATED 10/09/90. FILTUV1A.21
CLLEND------------------------------------------------------------- FILTUV1A.22
FILTUV1A.23
C*L ARGUMENTS:--------------------------------------------------- FILTUV1A.24
SUBROUTINE FILT_UV 1,8FILTUV1A.25
1 (PSTAR,U,V,RS_FUNCTIONS,DELTA_AK,DELTA_BK, FILTUV1A.26
2 P_FIELD,U_FIELD,NORTHERN_FILTERED_P_ROW, FILTUV1A.27
3 SOUTHERN_FILTERED_P_ROW,P_LEVELS, FILTUV1A.28
4 ROW_LENGTH, APB7F401.127
*CALL ARGFLDPT 
APB7F401.128
& TRIGS,IFAX, APB7F401.129
4 COS_LONGITUDE,SIN_LONGITUDE, FILTUV1A.30
5 FILTER_WAVE_NUMBER_U_ROWS) FILTUV1A.31
FILTUV1A.32
IMPLICIT NONE FILTUV1A.33
FILTUV1A.34
INTEGER FILTUV1A.35
* U_FIELD !IN DIMENSION OF FIELDS ON VELOCITY GRID FILTUV1A.36
*, P_FIELD !IN DIMENSION OF FIELDS ON PRESSURE GRID FILTUV1A.37
*, P_LEVELS !IN NUMBER OF MODEL LEVELS. FILTUV1A.38
*, ROW_LENGTH !IN NUMBER OF POINTS PER ROW FILTUV1A.39
*, NORTHERN_FILTERED_P_ROW !IN ROW ON WHICH FILTERING STOPS FILTUV1A.42
* ! MOVING TOWARDS EQUATOR. FILTUV1A.43
*, SOUTHERN_FILTERED_P_ROW !IN ROW ON WHICH FILTERING STARTS AGAIN FILTUV1A.44
* ! MOVING TOWARDS SOUTH POLE. FILTUV1A.45
*, IFAX(10) !IN HOLDS FACTORS OF ROW_LENGTH USED BY FILTUV1A.48
* ! FILTERING. FILTUV1A.49
APB7F401.130
! All TYPFLDPT arguments are intent IN APB7F401.131
*CALL TYPFLDPT APB7F401.132
FILTUV1A.50
INTEGER APB0F402.84
& FILTER_WAVE_NUMBER_U_ROWS(GLOBAL_U_FIELD/GLOBAL_ROW_LENGTH) APB0F402.85
! LAST WAVE NUMBER NOT TO BE CHOPPED APB0F402.86
REAL FILTUV1A.51
* U(U_FIELD,P_LEVELS) !INOUT U VELOCITY FIELD. FILTUV1A.52
*,V(U_FIELD,P_LEVELS) !INOUT V VELOCITY FIELD. FILTUV1A.53
FILTUV1A.54
REAL FILTUV1A.55
* PSTAR(P_FIELD) !IN PSTAR FIELD. FILTUV1A.56
*,RS_FUNCTIONS(P_FIELD,P_LEVELS) !IN RS*RS*DELTA P FILTUV1A.57
*,DELTA_AK(P_LEVELS) !IN LAYER THICKNESS FILTUV1A.58
*,DELTA_BK(P_LEVELS) !IN LAYER THICKNESS FILTUV1A.59
*,TRIGS(ROW_LENGTH) !IN HOLDS TRIGONOMETRIC FUNCTIONS FILTUV1A.60
* ! USED IN FILTERING. FILTUV1A.61
*,COS_LONGITUDE(ROW_LENGTH) !IN COSINE LONGITUDE AT U POINTS FILTUV1A.62
*,SIN_LONGITUDE(ROW_LENGTH) !IN SINE LONGITUDE AT U POINTS FILTUV1A.63
C*--------------------------------------------------------------------- FILTUV1A.64
FILTUV1A.65
C*L DEFINE ARRAYS AND VARIABLES USED IN THIS ROUTINE----------------- FILTUV1A.66
C DEFINE LOCAL ARRAYS: 1 IS REQUIRED FILTUV1A.67
REAL FILTUV1A.68
* WORK(P_FIELD) ! GENERAL WORKSPACE. FILTUV1A.69
FILTUV1A.70
C*--------------------------------------------------------------------- FILTUV1A.71
C DEFINE LOCAL VARIABLES FILTUV1A.72
FILTUV1A.73
C REAL SCALARS FILTUV1A.74
REAL FILTUV1A.75
* SCALAR1(LAST_P_VALID_PT-FIRST_VALID_PT+1), GSS1F403.421
* SCALAR2(LAST_P_VALID_PT-FIRST_VALID_PT+1), GSS1F403.422
* SCALAR3 GSS1F403.423
FILTUV1A.77
C COUNT VARIABLES FOR DO LOOPS ETC. FILTUV1A.78
INTEGER FILTUV1A.79
* I,K FILTUV1A.80
*, NORTHERN_FILTERED_U_ROW ! U ROW ON WHICH FILTERING STOPS FILTUV1A.81
*, SOUTHERN_FILTERED_U_ROW ! U ROW ON WHICH FILTERING STARTS AGAIN FILTUV1A.82
*, FILTER_SPACE ! HORIZONTAL DIMENSION OF SPACE NEEDED IN FILTERING FILTUV1A.83
* ! ROUTINE. FILTUV1A.84
*, n_input ! no. of inputs for sqrt_v function GSS1F403.424
FILTUV1A.85
C*L EXTERNAL SUBROUTINE CALLS:--------------------------------------- FILTUV1A.86
EXTERNAL FILTUV1A.87
* P_TO_UV,FILTER,POLAR_UV FILTUV1A.88
C*--------------------------------------------------------------------- FILTUV1A.89
CL MAXIMUM VECTOR LENGTH ASSUMED IS P_FIELD FILTUV1A.90
CL--------------------------------------------------------------------- FILTUV1A.91
CL INTERNAL STRUCTURE. FILTUV1A.92
CL--------------------------------------------------------------------- FILTUV1A.93
CL FILTUV1A.94
CL--------------------------------------------------------------------- FILTUV1A.95
CL SECTION 1. MASS-WEIGHT U AND V FIELDS. FILTUV1A.96
CL--------------------------------------------------------------------- FILTUV1A.97
FILTUV1A.98
! QAN fix : blank out WORK array so halos don't contain junk APB7F401.133
DO I=1,P_FIELD APB7F401.134
WORK(I)=0.0 APB7F401.135
ENDDO APB7F401.136
APB7F401.137
CL LOOP OVER P_LEVELS. FILTUV1A.99
FILTUV1A.100
DO 100 K=1,P_LEVELS FILTUV1A.101
FILTUV1A.102
CL CALCULATE RS*DELTA P FROM RS*RS*DELTA P HELD IN RS_FUNCTIONS AND FILTUV1A.103
CL DELTA P. FILTUV1A.104
DO I=FIRST_VALID_PT,LAST_P_VALID_PT GSS1F403.425
SCALAR1(I-FIRST_VALID_PT+1) GSS1F403.426
& = DELTA_AK(K) + DELTA_BK(K)*PSTAR(I) GSS1F403.427
SCALAR2(I-FIRST_VALID_PT+1) GSS1F403.428
& = RS_FUNCTIONS(I,K)/SCALAR1(I-FIRST_VALID_PT+1) GSS1F403.429
END DO GSS1F403.430
FILTUV1A.110
n_input= LAST_P_VALID_PT-FIRST_VALID_PT+1 GSS1F403.431
*IF DEF,VECTLIB PXVECTLB.8
call sqrt_v(n_input,scalar2,scalar2) GSS1F403.433
*ELSE GSS1F403.434
DO I=1,n_input GSS1F403.435
scalar2(I)=sqrt(scalar2(I)) GSS1F403.436
END DO GSS1F403.437
*ENDIF GSS1F403.438
GSS1F403.439
DO I=FIRST_VALID_PT,LAST_P_VALID_PT GSS1F403.440
WORK(I) = SCALAR1(I-FIRST_VALID_PT+1) * GSS1F403.441
& SCALAR2(I-FIRST_VALID_PT+1) GSS1F403.442
END DO GSS1F403.443
GSS1F403.444
GSS1F403.445
CL CALL P_TO_UV TO TRANSFER RS*DELTA P TO U GRID. FILTUV1A.111
FILTUV1A.112
CALL P_TO_UV(WORK,RS_FUNCTIONS(1,K),P_FIELD,U_FIELD,ROW_LENGTH, FILTUV1A.113
& tot_P_ROWS) APB7F401.139
FILTUV1A.115
CL MASS WEIGHT U AND V FIELDS. FILTUV1A.116
FILTUV1A.117
DO 120 I=FIRST_VALID_PT,LAST_U_VALID_PT APB7F401.140
U(I,K) = U(I,K) * RS_FUNCTIONS(I,K) FILTUV1A.119
V(I,K) = V(I,K) * RS_FUNCTIONS(I,K) FILTUV1A.120
120 CONTINUE FILTUV1A.121
FILTUV1A.122
CL END LOOP OVER P_LEVELS. FILTUV1A.123
100 CONTINUE FILTUV1A.124
FILTUV1A.125
CL FILTUV1A.126
CL--------------------------------------------------------------------- FILTUV1A.127
CL SECTION 2. CALL FILTER TO FILTER FIELDS. FILTUV1A.128
CL--------------------------------------------------------------------- FILTUV1A.129
FILTUV1A.130
C SET NORTHERN AND SOUTHERN ROWS FOR U FILTERING. FILTUV1A.131
FILTUV1A.132
NORTHERN_FILTERED_U_ROW = NORTHERN_FILTERED_P_ROW FILTUV1A.133
SOUTHERN_FILTERED_U_ROW = SOUTHERN_FILTERED_P_ROW - 1 FILTUV1A.134
FILTUV1A.135
C SET FILTER_SPACE WHICH IS ROW_LENGTH+2 TIMES THE NUMBER OF ROWS TO FILTUV1A.136
C BE FILTERED. FILTUV1A.137
FILTUV1A.138
FILTER_SPACE = (ROW_LENGTH+2)*(NORTHERN_FILTERED_U_ROW-1+ FILTUV1A.139
* U_FIELD/ROW_LENGTH-SOUTHERN_FILTERED_U_ROW) FILTUV1A.140
FILTUV1A.141
CL CALL FILTER FOR U FILTUV1A.142
FILTUV1A.143
CALL FILTER(U,U_FIELD,P_LEVELS,FILTER_SPACE,ROW_LENGTH, FILTUV1A.144
*CALL ARGFLDPT APB0F402.87
* FILTER_WAVE_NUMBER_U_ROWS,TRIGS,IFAX, FILTUV1A.145
* NORTHERN_FILTERED_U_ROW,SOUTHERN_FILTERED_U_ROW) FILTUV1A.146
FILTUV1A.147
CL CALL FILTER FOR V FILTUV1A.148
FILTUV1A.149
CALL FILTER(V,U_FIELD,P_LEVELS,FILTER_SPACE,ROW_LENGTH, FILTUV1A.150
*CALL ARGFLDPT APB0F402.88
* FILTER_WAVE_NUMBER_U_ROWS,TRIGS,IFAX, FILTUV1A.151
* NORTHERN_FILTERED_U_ROW,SOUTHERN_FILTERED_U_ROW) FILTUV1A.152
FILTUV1A.153
CL FILTUV1A.154
CL--------------------------------------------------------------------- FILTUV1A.155
CL SECTION 3. REMOVE MASS-WEIGHTING FROM U AND V. FILTUV1A.156
CL--------------------------------------------------------------------- FILTUV1A.157
FILTUV1A.158
APB2F401.204
! CALL POLAR_UV TO UPDATE THE POLAR VALUES OF MASS-WEIGHTED U AND V APB2F401.205
APB2F401.206
CALL POLAR_UV(U,V,ROW_LENGTH,U_FIELD,P_LEVELS, APB2F401.207
*CALL ARGFLDPT APB2F401.208
& COS_LONGITUDE,SIN_LONGITUDE) APB2F401.209
CL LOOP OVER P_LEVELS. FILTUV1A.159
FILTUV1A.160
DO 300 K=1,P_LEVELS FILTUV1A.161
FILTUV1A.162
FILTUV1A.167
CL REMOVE MASS-WEIGHTING. FILTUV1A.168
FILTUV1A.169
CFPP$ SELECT(CONCUR) FILTUV1A.170
DO 310 I=FIRST_VALID_PT,LAST_U_VALID_PT APB7F401.141
SCALAR3 = 1./RS_FUNCTIONS(I,K) GSS1F403.446
U(I,K) = U(I,K) * SCALAR3 GSS1F403.447
V(I,K) = V(I,K) * SCALAR3 GSS1F403.448
310 CONTINUE FILTUV1A.175
FILTUV1A.176
CL END LOOP OVER P_LEVELS FILTUV1A.177
FILTUV1A.178
300 CONTINUE FILTUV1A.179
FILTUV1A.180
CL END OF ROUTINE FILT_UV FILTUV1A.181
FILTUV1A.182
RETURN FILTUV1A.183
END FILTUV1A.184
*ENDIF FILTUV1A.185