*IF DEF,A12_1B,OR,DEF,A12_1C,OR,DEF,A12_1D,OR,DEF,A12_1E AAD2F404.266
C ******************************COPYRIGHT****************************** GTS2F400.5797
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.5798
C GTS2F400.5799
C Use, duplication or disclosure of this code is subject to the GTS2F400.5800
C restrictions as set forth in the contract. GTS2F400.5801
C GTS2F400.5802
C Meteorological Office GTS2F400.5803
C London Road GTS2F400.5804
C BRACKNELL GTS2F400.5805
C Berkshire UK GTS2F400.5806
C RG12 2SZ GTS2F400.5807
C GTS2F400.5808
C If no contract has been raised with this copy of the code, the use, GTS2F400.5809
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.5810
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.5811
C Modelling at the above address. GTS2F400.5812
C ******************************COPYRIGHT****************************** GTS2F400.5813
C GTS2F400.5814
CLL SUBROUTINE MASS_UWT ----------------------------------------- MASUWT1A.3
CLL MASUWT1A.4
CLL PURPOSE: CALCULATES RS AND REMOVES MASS WEIGHTING FROM THETAL, MASUWT1A.5
CLL QT U AND V FIELDS. MASUWT1A.6
CLL NOT SUITABLE FOR SINGLE COLUMN USE. MASUWT1A.7
CLL MASUWT1A.8
CLL WRITTEN BY M.H MAWSON. MASUWT1A.9
CLL MASUWT1A.10
CLL MODEL MODIFICATION HISTORY FROM MODEL VERSION 3.0: MASUWT1A.11
CLL VERSION DATE MASUWT1A.12
CLL 3.1 24/02/93 Tidy code to remove QA Fortran messages. MM240293.45
CLL 3.4 22/06/94 Argument LLINTS added and passed to CALC_RS GSS1F304.847
CLL DEF NOWHBR replaced by LWHITBROM GSS1F304.848
CLL S.J.Swarbrick GSS1F304.849
! 3.5 28/03/95 MPP code: Take account of duff row APB0F305.53
! of U_FIELD data at bottom. APB0F305.54
! P.Burton APB0F305.55
! 4.1 02/04/96 Tidied up MPP code P.Burton APB0F401.1049
CLL MASUWT1A.13
CLL 4.4 14/07/97 RS output via arg list for use in FILTUV. AAD2F404.267
CLL A. Dickinson AAD2F404.268
CLL AAD2F404.269
CLL PROGRAMMING STANDARD: UNIFIED MODEL DOCUMENTATION PAPER NO. 4, MASUWT1A.14
CLL STANDARD B. VERSION 2, DATED 18/01/90 MASUWT1A.15
CLL MASUWT1A.16
CLL SYSTEM COMPONENTS COVERED: P12 (part) MASUWT1A.17
CLL MASUWT1A.18
CLL SYSTEM TASK: P1 MASUWT1A.19
CLL MASUWT1A.20
CLL DOCUMENTATION: NIL. MASUWT1A.21
CLLEND------------------------------------------------------------- MASUWT1A.22
MASUWT1A.23
C*L ARGUMENTS:--------------------------------------------------- MASUWT1A.24
SUBROUTINE MASS_UWT 1,3MASUWT1A.25
1 (RS_SQUARED_DELTAP,RS,THETAL,QT,U,V,PSTAR,AK, AAD2F404.270
2 BK,DELTA_AK,DELTA_BK,P_FIELD,U_FIELD,P_LEVELS, MASUWT1A.27
3 Q_LEVELS,ROW_LENGTH, APB0F401.1050
*CALL ARGFLDPT 
APB0F401.1051
4 LLINTS,LWHITBROM) APB0F401.1052
MASUWT1A.29
IMPLICIT NONE MASUWT1A.30
LOGICAL LLINTS, LWHITBROM GSS1F304.851
MASUWT1A.31
INTEGER MASUWT1A.32
* P_FIELD !IN DIMENSION OF FIELDS ON PRESSURE GRID MASUWT1A.33
*, U_FIELD !IN DIMENSION OF FIELDS ON VELOCITY GRID MASUWT1A.34
*, P_LEVELS !IN NUMBER OF PRESSURE LEVELS. MASUWT1A.35
*, Q_LEVELS !IN NUMBER OF MOIST LEVELS. MASUWT1A.36
*, ROW_LENGTH !IN NUMBER OF POINTS ON A ROW. MASUWT1A.37
! All TYPFLDPT arguments are intent IN APB0F401.1053
*CALL TYPFLDPT APB0F401.1054
MASUWT1A.38
REAL MASUWT1A.39
* QT(P_FIELD,Q_LEVELS) !INOUT. QT FIELD. MASUWT1A.40
*,THETAL(P_FIELD,P_LEVELS) !INOUT THETAL FIELD. MASUWT1A.41
*,U(U_FIELD,P_LEVELS) !INOUT U FIELD. MASUWT1A.42
*,V(U_FIELD,P_LEVELS) !INOUT U FIELD. MASUWT1A.43
MASUWT1A.44
REAL MASUWT1A.45
* RS_SQUARED_DELTAP(P_FIELD,P_LEVELS) !OUT HOLDS RS*RS*DELTA P MASUWT1A.46
*,RS(P_FIELD,P_LEVELS) !OUT HOLDS RS AAD2F404.271
MASUWT1A.47
REAL MASUWT1A.48
* PSTAR(P_FIELD) !IN SURFACE PRESSURE MASUWT1A.49
*,AK(P_LEVELS) !IN FIRST TERM IN HYBRID CO-ORDS MASUWT1A.50
*,BK(P_LEVELS) !IN SECOND TERM IN HYBRID CO-ORDS MASUWT1A.51
*,DELTA_AK(P_LEVELS) !IN LAYER THICKNESS TERM MASUWT1A.52
*,DELTA_BK(P_LEVELS) !IN LAYER THICKNESS TERM MASUWT1A.53
MASUWT1A.54
C*--------------------------------------------------------------------- MASUWT1A.55
MASUWT1A.56
C*L DEFINE ARRAYS AND VARIABLES USED IN THIS ROUTINE----------------- MASUWT1A.57
C DEFINE LOCAL ARRAYS: 1 IS REQUIRED MASUWT1A.58
MASUWT1A.59
REAL MASUWT1A.60
* WORK1(P_FIELD) !GENERAL WORKSPACE MASUWT1A.61
C*--------------------------------------------------------------------- MASUWT1A.62
C DEFINE LOCAL VARIABLES MASUWT1A.63
MASUWT1A.64
C COUNT VARIABLES FOR DO LOOPS ETC. MASUWT1A.65
INTEGER MASUWT1A.66
* I,K,ROWS,POINTS APB0F401.1055
MASUWT1A.68
REAL MASUWT1A.69
* SCALAR MASUWT1A.70
C*L EXTERNAL SUBROUTINE CALLS:--------------------------------------- MASUWT1A.71
MASUWT1A.72
EXTERNAL MASUWT1A.73
* P_TO_UV MASUWT1A.74
* ,CALC_RS GSS1F304.852
MASUWT1A.78
*CALL C_A MASUWT1A.79
MASUWT1A.81
C*--------------------------------------------------------------------- MASUWT1A.82
CL MAXIMUM VECTOR LENGTH ASSUMED IS P_FIELD. MASUWT1A.83
CL--------------------------------------------------------------------- MASUWT1A.84
CL INTERNAL STRUCTURE. MASUWT1A.85
CL--------------------------------------------------------------------- MASUWT1A.86
CL MASUWT1A.87
POINTS=LAST_P_VALID_PT-FIRST_VALID_PT+1 APB0F401.1056
! Number of points to be processed by CALC_RS. For non-MPP runs this APB0F401.1057
! is simply P_FIELD, for MPP, it is all the points, minus any APB0F401.1058
! unused halo areas (ie. the halo above North pole row, and beneath APB0F401.1059
! South pole row) APB0F401.1060
APB0F401.1061
IF (LWHITBROM) THEN GSS1F304.853
CL GSS1F304.854
CL--------------------------------------------------------------------- MASUWT1A.89
CL SECTION 1. CALL CALC_RS TO CALCULATE RS. MASUWT1A.90
CL--------------------------------------------------------------------- MASUWT1A.91
MASUWT1A.92
CL CALL CALC_RS TO GET RS FOR LEVEL 1. MASUWT1A.93
C TS IS RETURNED IN WORK1, RS AT LEVEL K-1 IS INPUT IN MASUWT1A.95
C RS( ,2) AS AT K-1= 0 THE INPUT IS NOT USED BY CALC_RS. AAD2F404.272
MASUWT1A.97
K=1 MASUWT1A.98
CALL CALC_RS(PSTAR(FIRST_VALID_PT),AK,BK,WORK1(FIRST_VALID_PT), APB0F401.1062
& RS(FIRST_VALID_PT,2), AAD2F404.273
* RS(FIRST_VALID_PT,K), AAD2F404.274
& POINTS,K,P_LEVELS,LLINTS) APB0F401.1065
MASUWT1A.101
CL LOOP FROM 2 TO P_LEVELS MASUWT1A.102
DO 100 K= 2,P_LEVELS MASUWT1A.103
MASUWT1A.104
CL CALL CALC_RS TO GET RS FOR LEVEL K. MASUWT1A.105
C TS IS RETURNED IN WORK1, RS AT LEVEL K-1 IS INPUT AS MASUWT1A.107
C RS(K-1). AAD2F404.275
MASUWT1A.109
CALL CALC_RS(PSTAR(FIRST_VALID_PT),AK,BK,WORK1(FIRST_VALID_PT), APB0F401.1066
& RS(FIRST_VALID_PT,K-1), AAD2F404.276
& RS(FIRST_VALID_PT,K), AAD2F404.277
& POINTS,K,P_LEVELS,LLINTS) APB0F401.1069
100 CONTINUE MASUWT1A.113
MASUWT1A.114
CL END LOOP FROM 2 TO P_LEVELS. MASUWT1A.115
MASUWT1A.116
END IF ! LWHITBROM GSS1F304.859
CL MASUWT1A.118
CL--------------------------------------------------------------------- MASUWT1A.119
C IF (.NOT.LWHITBROM) THEN GSS1F304.860
CL SECTION 1 CALCULATE A*A*DELTA P AND REMOVE MASS-WEIGHTING MASUWT1A.121
C ELSE GSS1F304.861
CL SECTION 2 CALCULATE RS*RS*DELTA P AND REMOVE MASS-WEIGHTING MASUWT1A.123
C END IF GSS1F304.862
CL FROM THETAL AND QT. MASUWT1A.125
CL--------------------------------------------------------------------- MASUWT1A.126
MASUWT1A.127
CL LOOP OVER MOIST LEVELS, IE: Q_LEVELS. MASUWT1A.128
DO 200 K=1,Q_LEVELS MASUWT1A.129
CFPP$ SELECT(CONCUR) MASUWT1A.130
AAD2F404.278
! loop over all points, including valid halos APB0F401.1070
DO 210 I=FIRST_VALID_PT,LAST_P_VALID_PT APB0F401.1071
MASUWT1A.132
IF (.NOT.LWHITBROM) THEN GSS1F304.863
GSS1F304.864
CL CALCULATE A*A*DELTAP MASUWT1A.134
RS(I,K) = A AAD2F404.279
RS_SQUARED_DELTAP(I,K) = A*A* MASUWT1A.135
* (DELTA_AK(K)+DELTA_BK(K)*PSTAR(I)) GSS1F304.865
SCALAR = 1./RS_SQUARED_DELTAP(I,K) GSS1F304.866
GSS1F304.867
ELSE GSS1F304.868
GSS1F304.869
CL CALCULATE RS*RS*DELTAP MASUWT1A.137
RS_SQUARED_DELTAP(I,K) = RS(I,K) * AAD2F404.280
* RS(I,K) * AAD2F404.281
* (DELTA_AK(K)+DELTA_BK(K)*PSTAR(I)) MASUWT1A.141
SCALAR = 1./RS_SQUARED_DELTAP(I,K) MASUWT1A.142
MASUWT1A.143
END IF GSS1F304.870
GSS1F304.871
CL REMOVE MASS-WEIGHTING FROM THETAL AND QT. MASUWT1A.144
THETAL(I,K) = THETAL(I,K)*SCALAR MASUWT1A.145
QT(I,K) = QT(I,K)*SCALAR MASUWT1A.146
210 CONTINUE MASUWT1A.147
CL END LOOP OVER MOIST LEVELS. MASUWT1A.148
200 CONTINUE MASUWT1A.149
MASUWT1A.150
CL LOOP OVER ANY REMAINING DRY LEVELS, IE: Q_LEVELS+1 TO P_LEVELS MASUWT1A.151
MASUWT1A.152
DO 220 K= Q_LEVELS+1, P_LEVELS MASUWT1A.153
CFPP$ SELECT(CONCUR) MASUWT1A.154
! loop over all points, including valid halos APB0F401.1072
DO 230 I=FIRST_VALID_PT,LAST_P_VALID_PT APB0F401.1073
MASUWT1A.156
IF (.NOT.LWHITBROM) THEN GSS1F304.872
GSS1F304.873
CL CALCULATE A*A*DELTAP MASUWT1A.158
RS(I,K) = A AAD2F404.282
RS_SQUARED_DELTAP(I,K) = A*A* MASUWT1A.159
* (DELTA_AK(K)+DELTA_BK(K)*PSTAR(I)) GSS1F304.874
GSS1F304.875
ELSE GSS1F304.876
GSS1F304.877
CL CALCULATE RS*RS*DELTAP MASUWT1A.161
RS_SQUARED_DELTAP(I,K) = RS(I,K) * AAD2F404.283
* RS(I,K) * AAD2F404.284
* (DELTA_AK(K)+DELTA_BK(K)*PSTAR(I)) MASUWT1A.165
GSS1F304.878
END IF GSS1F304.879
MASUWT1A.166
CL REMOVE MASS-WEIGHTING FROM THETAL. MASUWT1A.167
THETAL(I,K) = THETAL(I,K)/RS_SQUARED_DELTAP(I,K) MASUWT1A.168
230 CONTINUE MASUWT1A.169
MASUWT1A.170
CL END LOOP OVER REMAINING DRY LEVELS. MASUWT1A.171
220 CONTINUE MASUWT1A.172
MASUWT1A.173
CL MASUWT1A.174
CL--------------------------------------------------------------------- MASUWT1A.175
C IF (.NOT.LWHITBROM) THEN GSS1F304.880
CL SECTION 2 INTERPOLATE A*A*DELTA P ONTO U GRID AND REMOVE MASUWT1A.177
C ELSE GSS1F304.881
CL SECTION 3 INTERPOLATE RS*RS*DELTA P ONTO U GRID AND REMOVE MASUWT1A.179
C END IF GSS1F304.882
CL MASS-WEIGHTING FROM U AND V. MASUWT1A.181
CL--------------------------------------------------------------------- MASUWT1A.182
MASUWT1A.183
C SET ROWS MASUWT1A.184
ROWS = P_FIELD/ROW_LENGTH MASUWT1A.185
MASUWT1A.186
CL LOOP OVER P_LEVELS MASUWT1A.187
DO 300 K=1,P_LEVELS MASUWT1A.188
MASUWT1A.189
C IF (.NOT.LWHITBROM) THEN GSS1F304.883
CL CALL P_TO_UV TO OBTAIN A*A*DELTA P ON U GRID. MASUWT1A.191
C ELSE GSS1F304.884
CL CALL P_TO_UV TO OBTAIN RS*RS*DELTA P ON U GRID. MASUWT1A.193
C END IF GSS1F304.885
MASUWT1A.195
CALL P_TO_UV(RS_SQUARED_DELTAP(1,K),WORK1,P_FIELD,U_FIELD, MASUWT1A.196
* ROW_LENGTH,ROWS) MASUWT1A.197
MASUWT1A.198
! loop over "local" points - not including top and bottom halos APB0F401.1074
DO 310 I=FIRST_FLD_PT,LAST_U_FLD_PT APB0F401.1075
CL REMOVE MASS-WEIGHTING FROM U AND V. MASUWT1A.200
MASUWT1A.201
SCALAR = 1./WORK1(I) MASUWT1A.202
U(I,K) = U(I,K)*SCALAR MASUWT1A.203
V(I,K) = V(I,K)*SCALAR MASUWT1A.204
310 CONTINUE MASUWT1A.205
MASUWT1A.206
CL END LOOP OVER P_LEVELS. MASUWT1A.207
300 CONTINUE MASUWT1A.208
MASUWT1A.209
CL END OF ROUTINE MASS_UWT MASUWT1A.210
MASUWT1A.211
RETURN MASUWT1A.212
END MASUWT1A.213
*ENDIF MASUWT1A.214