*IF DEF,A12_1B,OR,DEF,A12_1C,OR,DEF,A12_1D,OR,DEF,A12_1E AAD2F404.251
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.14878
C GTS2F400.14879
C Use, duplication or disclosure of this code is subject to the GTS2F400.14880
C restrictions as set forth in the contract. GTS2F400.14881
C GTS2F400.14882
C Meteorological Office GTS2F400.14883
C London Road GTS2F400.14884
C BRACKNELL GTS2F400.14885
C Berkshire UK GTS2F400.14886
C RG12 2SZ GTS2F400.14887
C GTS2F400.14888
C If no contract has been raised with this copy of the code, the use, GTS2F400.14889
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.14890
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.14891
C Modelling at the above address. GTS2F400.14892
C ******************************COPYRIGHT****************************** GTS2F400.14893
C GTS2F400.14894
CLL SUBROUTINE MASS_UWT_UV ----------------------------------------- MASUVW1A.3
CLL MASUVW1A.4
CLL PURPOSE: CALCULATES RS AND REMOVES MASS WEIGHTING FROM U AND V MASUVW1A.5
CLL MASUVW1A.6
CLL NOT SUITABLE FOR SINGLE COLUMN USE. MASUVW1A.7
CLL MASUVW1A.8
CLL MODEL MODIFICATION HISTORY: MASUVW1A.9
CLL VERSION DATE MASUVW1A.10
CLL 4.0 02/02/95 Original code: T.Davies MASUVW1A.11
! 4.1 02/04/96 Added MPP code P.Burton APB0F401.1077
CLL MASUVW1A.12
CLL 4.4 14/07/97 RS output via arg list for use in FILTUV. AAD2F404.252
CLL A. Dickinson AAD2F404.253
CLL AAD2F404.254
CLL PROGRAMMING STANDARD: UNIFIED MODEL DOCUMENTATION PAPER NO. 4, MASUVW1A.13
CLL STANDARD B. VERSION 2, DATED 18/01/90 MASUVW1A.14
CLL MASUVW1A.15
CLL SYSTEM COMPONENTS COVERED: P12 (part) MASUVW1A.16
CLL MASUVW1A.17
CLL SYSTEM TASK: P1 MASUVW1A.18
CLL MASUVW1A.19
CLL DOCUMENTATION: NIL. MASUVW1A.20
CLLEND------------------------------------------------------------- MASUVW1A.21
MASUVW1A.22
C*L ARGUMENTS:--------------------------------------------------- MASUVW1A.23
SUBROUTINE MASS_UWT_UV 1,3MASUVW1A.24
1 (RS_SQUARED_DELTAP,RS,U,V,PSTAR,AK, AAD2F404.255
2 BK,DELTA_AK,DELTA_BK,P_FIELD,U_FIELD,P_LEVELS, MASUVW1A.26
3 ROW_LENGTH, APB0F401.1078
*CALL ARGFLDPT 
APB0F401.1079
4 LLINTS,LWHITBROM) APB0F401.1080
MASUVW1A.28
IMPLICIT NONE MASUVW1A.29
LOGICAL LLINTS, LWHITBROM MASUVW1A.30
MASUVW1A.31
INTEGER MASUVW1A.32
* P_FIELD !IN DIMENSION OF FIELDS ON PRESSURE GRID MASUVW1A.33
*, U_FIELD !IN DIMENSION OF FIELDS ON VELOCITY GRID MASUVW1A.34
*, P_LEVELS !IN NUMBER OF PRESSURE LEVELS. MASUVW1A.35
*, ROW_LENGTH !IN NUMBER OF POINTS ON A ROW. MASUVW1A.36
APB0F401.1081
! All TYPFLDPT arguments are intent IN APB0F401.1082
*CALL TYPFLDPT APB0F401.1083
APB0F401.1084
MASUVW1A.37
REAL MASUVW1A.38
* U(U_FIELD,P_LEVELS) !INOUT U FIELD. MASUVW1A.39
*,V(U_FIELD,P_LEVELS) !INOUT U FIELD. MASUVW1A.40
MASUVW1A.41
REAL MASUVW1A.42
* RS_SQUARED_DELTAP(P_FIELD,P_LEVELS) !OUT HOLDS RS*RS*DELTA P MASUVW1A.43
*,RS(P_FIELD,P_LEVELS) !OUT HOLDS RS AAD2F404.256
MASUVW1A.44
REAL MASUVW1A.45
* PSTAR(P_FIELD) !IN SURFACE PRESSURE MASUVW1A.46
*,AK(P_LEVELS) !IN FIRST TERM IN HYBRID CO-ORDS MASUVW1A.47
*,BK(P_LEVELS) !IN SECOND TERM IN HYBRID CO-ORDS MASUVW1A.48
*,DELTA_AK(P_LEVELS) !IN LAYER THICKNESS TERM MASUVW1A.49
*,DELTA_BK(P_LEVELS) !IN LAYER THICKNESS TERM MASUVW1A.50
MASUVW1A.51
C*--------------------------------------------------------------------- MASUVW1A.52
MASUVW1A.53
C*L DEFINE ARRAYS AND VARIABLES USED IN THIS ROUTINE----------------- MASUVW1A.54
C DEFINE LOCAL ARRAYS: 1 IS REQUIRED MASUVW1A.55
MASUVW1A.56
REAL MASUVW1A.57
* WORK1(P_FIELD) !GENERAL WORKSPACE MASUVW1A.58
C*--------------------------------------------------------------------- MASUVW1A.59
C DEFINE LOCAL VARIABLES MASUVW1A.60
MASUVW1A.61
C COUNT VARIABLES FOR DO LOOPS ETC. MASUVW1A.62
INTEGER MASUVW1A.63
* I,K,ROWS,POINTS APB0F401.1085
MASUVW1A.65
C*L EXTERNAL SUBROUTINE CALLS:--------------------------------------- MASUVW1A.66
MASUVW1A.67
EXTERNAL MASUVW1A.68
* P_TO_UV MASUVW1A.69
* ,CALC_RS MASUVW1A.70
MASUVW1A.71
*CALL C_A MASUVW1A.72
MASUVW1A.73
C*--------------------------------------------------------------------- MASUVW1A.74
CL MAXIMUM VECTOR LENGTH ASSUMED IS P_FIELD. MASUVW1A.75
CL--------------------------------------------------------------------- MASUVW1A.76
CL INTERNAL STRUCTURE. MASUVW1A.77
CL--------------------------------------------------------------------- MASUVW1A.78
CL MASUVW1A.79
POINTS=LAST_P_VALID_PT-FIRST_VALID_PT+1 APB0F401.1086
! Number of points to be processed by CALC_RS. For non-MPP runs this APB0F401.1087
! is simply P_FIELD, for MPP, it is all the points, minus any APB0F401.1088
! unused halo areas (ie. the halo above North pole row, and beneath APB0F401.1089
! South pole row) APB0F401.1090
IF (LWHITBROM) THEN MASUVW1A.80
CL MASUVW1A.81
CL--------------------------------------------------------------------- MASUVW1A.82
CL SECTION 1. CALL CALC_RS TO CALCULATE RS. MASUVW1A.83
CL--------------------------------------------------------------------- MASUVW1A.84
MASUVW1A.85
CL CALL CALC_RS TO GET RS FOR LEVEL 1. MASUVW1A.86
C TS IS RETURNED IN WORK1, RS AT LEVEL K-1 IS INPUT IN MASUVW1A.88
C RS( ,2) AS AT K-1= 0 THE INPUT IS NOT USED BY CALC_RS. AAD2F404.257
MASUVW1A.90
K=1 MASUVW1A.91
CALL CALC_RS(PSTAR(FIRST_VALID_PT),AK,BK,WORK1(FIRST_VALID_PT), APB0F401.1091
& RS(FIRST_VALID_PT,2), AAD2F404.258
* RS(FIRST_VALID_PT,K), AAD2F404.259
& POINTS,K,P_LEVELS,LLINTS) APB0F401.1094
MASUVW1A.95
CL LOOP FROM 2 TO P_LEVELS MASUVW1A.96
DO K= 2,P_LEVELS MASUVW1A.97
MASUVW1A.98
CL CALL CALC_RS TO GET RS FOR LEVEL K. MASUVW1A.99
C TS IS RETURNED IN WORK1, RS AT LEVEL K-1 IS INPUT AS MASUVW1A.101
C RS(K-1). AAD2F404.260
MASUVW1A.103
CALL CALC_RS(PSTAR(FIRST_VALID_PT),AK,BK,WORK1(FIRST_VALID_PT), APB0F401.1095
& RS(FIRST_VALID_PT,K-1), AAD2F404.261
& RS(FIRST_VALID_PT,K), AAD2F404.262
& POINTS,K,P_LEVELS,LLINTS) APB0F401.1098
END DO MASUVW1A.108
MASUVW1A.109
CL END LOOP FROM 2 TO P_LEVELS. MASUVW1A.110
MASUVW1A.111
END IF ! LWHITBROM MASUVW1A.112
CL MASUVW1A.113
CL--------------------------------------------------------------------- MASUVW1A.114
C IF (.NOT.LWHITBROM) THEN MASUVW1A.115
CL SECTION 1 CALCULATE A*A*DELTA P AND REMOVE MASS-WEIGHTING MASUVW1A.116
C ELSE MASUVW1A.117
CL SECTION 2 CALCULATE RS*RS*DELTA P AND REMOVE MASS-WEIGHTING MASUVW1A.118
C END IF MASUVW1A.119
CL FROM THETAL AND QT. MASUVW1A.120
CL--------------------------------------------------------------------- MASUVW1A.121
MASUVW1A.122
CL LOOP OVER LEVELS MASUVW1A.123
DO K=1,P_LEVELS MASUVW1A.124
CFPP$ SELECT(CONCUR) MASUVW1A.125
! loop over all points, including valid halos APB0F401.1099
DO I=FIRST_VALID_PT,LAST_P_VALID_PT APB0F401.1100
MASUVW1A.127
IF (.NOT.LWHITBROM) THEN MASUVW1A.128
MASUVW1A.129
CL CALCULATE A*A*DELTAP MASUVW1A.130
RS(I,K) = A AAD2F404.263
RS_SQUARED_DELTAP(I,K) = A*A* MASUVW1A.131
* (DELTA_AK(K)+DELTA_BK(K)*PSTAR(I)) MASUVW1A.132
ELSE MASUVW1A.133
MASUVW1A.134
CL CALCULATE RS*RS*DELTAP MASUVW1A.135
RS_SQUARED_DELTAP(I,K) = RS(I,K) * AAD2F404.264
* RS(I,K) * AAD2F404.265
* (DELTA_AK(K)+DELTA_BK(K)*PSTAR(I)) MASUVW1A.138
END IF MASUVW1A.139
MASUVW1A.140
END DO MASUVW1A.141
MASUVW1A.142
CL END LOOP OVERLEVELS. MASUVW1A.143
END DO MASUVW1A.144
MASUVW1A.145
MASUVW1A.146
CL MASUVW1A.147
CL--------------------------------------------------------------------- MASUVW1A.148
C IF (.NOT.LWHITBROM) THEN MASUVW1A.149
CL SECTION 2 INTERPOLATE A*A*DELTA P ONTO U GRID AND REMOVE MASUVW1A.150
C ELSE MASUVW1A.151
CL SECTION 3 INTERPOLATE RS*RS*DELTA P ONTO U GRID AND REMOVE MASUVW1A.152
C END IF MASUVW1A.153
CL MASS-WEIGHTING FROM U AND V. MASUVW1A.154
CL--------------------------------------------------------------------- MASUVW1A.155
MASUVW1A.156
C SET ROWS MASUVW1A.157
ROWS = P_FIELD/ROW_LENGTH MASUVW1A.158
MASUVW1A.159
CL LOOP OVER P_LEVELS MASUVW1A.160
DO K=1,P_LEVELS MASUVW1A.161
MASUVW1A.162
C IF (.NOT.LWHITBROM) THEN MASUVW1A.163
CL CALL P_TO_UV TO OBTAIN A*A*DELTA P ON U GRID. MASUVW1A.164
C ELSE MASUVW1A.165
CL CALL P_TO_UV TO OBTAIN RS*RS*DELTA P ON U GRID. MASUVW1A.166
C END IF MASUVW1A.167
MASUVW1A.168
CALL P_TO_UV(RS_SQUARED_DELTAP(1,K),WORK1,P_FIELD,U_FIELD, MASUVW1A.169
* ROW_LENGTH,ROWS) MASUVW1A.170
MASUVW1A.171
! loop over "local" points - not including top and bottom halos APB0F401.1101
DO I=FIRST_FLD_PT,LAST_U_FLD_PT APB0F401.1102
CL REMOVE MASS-WEIGHTING FROM U AND V. MASUVW1A.173
MASUVW1A.174
U(I,K) = U(I,K)/WORK1(I) MASUVW1A.175
V(I,K) = V(I,K)/WORK1(I) MASUVW1A.176
END DO MASUVW1A.177
MASUVW1A.178
CL END LOOP OVER P_LEVELS. MASUVW1A.179
END DO MASUVW1A.180
MASUVW1A.181
CL END OF ROUTINE MASS_UWT_UV MASUVW1A.182
MASUVW1A.183
RETURN MASUVW1A.184
END MASUVW1A.185
*ENDIF MASUVW1A.186