*IF DEF,A14_1A EMDIAG1A.2
C ******************************COPYRIGHT****************************** GTS2F400.2377
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.2378
C GTS2F400.2379
C Use, duplication or disclosure of this code is subject to the GTS2F400.2380
C restrictions as set forth in the contract. GTS2F400.2381
C GTS2F400.2382
C Meteorological Office GTS2F400.2383
C London Road GTS2F400.2384
C BRACKNELL GTS2F400.2385
C Berkshire UK GTS2F400.2386
C RG12 2SZ GTS2F400.2387
C GTS2F400.2388
C If no contract has been raised with this copy of the code, the use, GTS2F400.2389
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.2390
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.2391
C Modelling at the above address. GTS2F400.2392
C ******************************COPYRIGHT****************************** GTS2F400.2393
C GTS2F400.2394
CLL SUBROUTINE ENG_MASS_DIAG------------------------------------------ EMDIAG1A.3
CLL EMDIAG1A.4
CLL PURPOSE : PART OF ENERGY CORRECTION SUITE OF ROUTINES EMDIAG1A.5
CLL - TO GLOBALLY INTERGATE TOTAL ENERGY AMD MASS OF EMDIAG1A.6
CLL THE ATMOSPHERE EMDIAG1A.7
CLL EMDIAG1A.8
CLL NOT SUITABLE FOR SINGLE COLUMN MODEL USE EMDIAG1A.9
CLL EMDIAG1A.10
CLL CODE WRITTEN FOR CRAY Y-MP BY D.GREGORY FEBRUARY 1991 EMDIAG1A.11
CLL EMDIAG1A.12
CLL MODEL MODIFICATION HISTORY FROM MODEL VERSION 3.0: EMDIAG1A.13
CLL VERSION DATE EMDIAG1A.14
CLL 3.4 26/05/94 Argument LLINTS added and passed to CALC_RS GSS1F304.821
CLL DEF NOWHBR replaced by LOGICAL LWHITBROM GSS1F304.822
CLL S.J.Swarbrick GSS1F304.823
! 4.1 24/11/95 Changed interface to ENERGY/MASS_SUM to make APB5F401.8
! suitable for MPP use and added TYPFLDPT APB5F401.9
! arguments. P.Burton APB5F401.10
CLL EMDIAG1A.15
CLL PROGRAMMING STANDARDS : UNIFIED MODEL DOCUMENTATION PAPER NO. 4 EMDIAG1A.16
CLL VERSION NO. 1 EMDIAG1A.17
CLL EMDIAG1A.18
CLL SYSTEM TASK : P## EMDIAG1A.19
CLL EMDIAG1A.20
CLL DOCUMENTATION : UNIFIED MODEL DOCUMENTATION PAPER P### EMDIAG1A.21
CLL EMDIAG1A.22
CLLEND----------------------------------------------------------------- EMDIAG1A.23
C EMDIAG1A.24
C*L ARGUMENTS--------------------------------------------------------- EMDIAG1A.25
C EMDIAG1A.26
SUBROUTINE ENG_MASS_DIAG (TL,U,V,AREA_P,AREA_UV,P_FIELD, 2,17EMDIAG1A.27
& U_FIELD,ROW_LENGTH,ROWS, APB5F401.11
2 DELTA_AK,DELTA_BK,AK,BK,TOT_ENERGY, EMDIAG1A.29
3 TOT_MASS_P,PART_MASS_P,P_LEVELS,PSTAR, GSS1F304.824
*CALL ARGFLDPT 
APB5F401.12
4 LLINTS,LWHITBROM) GSS1F304.825
C EMDIAG1A.31
IMPLICIT NONE EMDIAG1A.32
LOGICAL LLINTS,LWHITBROM GSS1F304.826
*CALL C_R_CP EMDIAG1A.33
*CALL C_A EMDIAG1A.34
C EMDIAG1A.35
C---------------------------------------------------------------------- EMDIAG1A.36
C VECTOR LENGTHS EMDIAG1A.37
C---------------------------------------------------------------------- EMDIAG1A.38
C EMDIAG1A.39
C EMDIAG1A.40
INTEGER P_FIELD ! IN VECTOR LENGTH OF VARIABLES ON EMDIAG1A.41
! P GRID EMDIAG1A.42
C EMDIAG1A.43
INTEGER U_FIELD ! IN VECTOR LENGTH OF VARIABLES ON EMDIAG1A.44
! UV GRID EMDIAG1A.45
C EMDIAG1A.46
C EMDIAG1A.49
INTEGER ROW_LENGTH ! IN NUMBER OF POINTS PER ROW EMDIAG1A.50
C EMDIAG1A.51
INTEGER ROWS ! IN NUMBER OF ROWS IN P GRID EMDIAG1A.52
C EMDIAG1A.53
INTEGER P_LEVELS ! IN NUMBER OF LEVELS IN VERTICAL EMDIAG1A.54
APB5F401.13
! All TYPFLDPT arguments are intent IN APB5F401.14
*CALL TYPFLDPT APB5F401.15
APB5F401.16
C EMDIAG1A.55
C EMDIAG1A.56
C---------------------------------------------------------------------- EMDIAG1A.57
C VARIABLES WHICH ARE INPUT EMDIAG1A.58
C---------------------------------------------------------------------- EMDIAG1A.59
C EMDIAG1A.60
REAL TL(P_FIELD,P_LEVELS) !IN TEMPERATURE EMDIAG1A.61
C EMDIAG1A.62
REAL U(U_FIELD,P_LEVELS) !IN COMPONENT OF WIND EMDIAG1A.63
C EMDIAG1A.64
REAL V(U_FIELD,P_LEVELS) !IN COMPONENT OF WIND EMDIAG1A.65
C EMDIAG1A.66
REAL AREA_P(P_FIELD) !IN AREA OF CELLS IN P GRID EMDIAG1A.67
C EMDIAG1A.68
REAL AREA_UV(U_FIELD) !IN AREA OF CELLS IN UV GRID EMDIAG1A.69
C EMDIAG1A.70
REAL DELTA_AK(P_LEVELS) ! IN |THICKNESS OF LAYERS IN EMDIAG1A.71
C | EMDIAG1A.72
REAL DELTA_BK(P_LEVELS) ! IN |ETA CO-ORDINATES EMDIAG1A.73
C EMDIAG1A.74
REAL AK(P_LEVELS) ! IN |ETA CO-ORDINATES OF EMDIAG1A.75
C | EMDIAG1A.76
REAL BK(P_LEVELS) ! IN |MID-LAYER POINTS EMDIAG1A.77
C EMDIAG1A.78
REAL PSTAR(P_FIELD) !IN PRESSURE AT SURFACE EMDIAG1A.79
C EMDIAG1A.80
C EMDIAG1A.81
C---------------------------------------------------------------------- EMDIAG1A.82
C VARIABLES WHICH ARE IN AND OUT EMDIAG1A.83
C---------------------------------------------------------------------- EMDIAG1A.84
C EMDIAG1A.85
REAL TOT_ENERGY ! TOTAL ENERGY OF ATMOSPHERE EMDIAG1A.86
C EMDIAG1A.87
REAL TOT_MASS_P ! TOTAL MASS OF ATMOSPHERE EMDIAG1A.88
C EMDIAG1A.89
REAL PART_MASS_P ! PARTIAL MASS OF ATMOSPHERE EMDIAG1A.90
C EMDIAG1A.91
C EMDIAG1A.92
C---------------------------------------------------------------------- EMDIAG1A.93
C VARIABLES WHICH ARE DEFINED LOCALLY EMDIAG1A.94
C---------------------------------------------------------------------- EMDIAG1A.95
C EMDIAG1A.96
REAL PSTAR_DELBK(P_FIELD) ! PRESSURE_AT_SURFACE*DELTA_BK EMDIAG1A.97
C EMDIAG1A.98
REAL DELP_P(P_FIELD) ! MASS ELEMENTS ON P GRID EMDIAG1A.99
C EMDIAG1A.100
REAL DELP_UV(U_FIELD) ! MASS ELEMENTS ON UV GRID EMDIAG1A.101
C EMDIAG1A.102
REAL RS_P_K(P_FIELD) ! RADII ON P GRID EMDIAG1A.103
C EMDIAG1A.104
REAL RS_UV_K(U_FIELD) ! RADII ON UV GRID EMDIAG1A.105
C EMDIAG1A.106
REAL WORK(P_FIELD) ! DUMMY VARIABLE EMDIAG1A.107
C EMDIAG1A.108
REAL TS(P_FIELD) ! OUTPUT FROM SUBROUTINE CALC_RS EMDIAG1A.109
C EMDIAG1A.110
C EMDIAG1A.111
C---------------------------------------------------------------------- EMDIAG1A.112
C INTERNAL LOOP COUNTERS EMDIAG1A.113
C---------------------------------------------------------------------- EMDIAG1A.114
C EMDIAG1A.115
INTEGER I ! LOOP COUNTER EMDIAG1A.116
C EMDIAG1A.117
INTEGER K ! LOOP COUNTER EMDIAG1A.118
INTEGER POINTS ! Number of points for CALC_RS to process APB5F401.17
C EMDIAG1A.119
C---------------------------------------------------------------------- EMDIAG1A.120
C EXTERNAL SUBROUTINE CALLS - P_TO_UV,CALC_RS,ENERGY_SUM,MASS_SUM EMDIAG1A.121
C---------------------------------------------------------------------- EMDIAG1A.122
C EMDIAG1A.123
C*--------------------------------------------------------------------- EMDIAG1A.124
C EMDIAG1A.125
POINTS=LAST_P_VALID_PT-FIRST_VALID_PT+1 APB5F401.18
! Number of points to be processed by CALC_RS. For non-MPP runs this APB5F401.19
! is simply P_FIELD, for MPP, it is all the points, minus any APB5F401.20
! unused halo areas (ie. the halo above North pole row, and beneath APB5F401.21
! South pole row) APB5F401.22
C---------------------------------------------------------------------- EMDIAG1A.126
C ZERO MASS OF ATMOSPHERE EMDIAG1A.127
C---------------------------------------------------------------------- EMDIAG1A.128
C EMDIAG1A.129
TOT_MASS_P = 0.0 EMDIAG1A.130
PART_MASS_P = 0.0 EMDIAG1A.131
*IF DEF,MPP APB5F401.23
! QAN fix APB5F401.24
! Zero DELP_P and RS_P_Karray APB5F401.25
DO I=1,P_FIELD APB5F401.26
DELP_P(I)=0.0 APB5F401.27
RS_P_K(I)=0.0 APB5F401.28
ENDDO APB5F401.29
*ENDIF APB5F401.30
C EMDIAG1A.132
C---------------------------------------------------------------------- EMDIAG1A.133
C ZERO ENERGY OF ATMOSPHERE EMDIAG1A.134
C---------------------------------------------------------------------- EMDIAG1A.135
C EMDIAG1A.136
TOT_ENERGY = 0.0 EMDIAG1A.137
C EMDIAG1A.138
C====================================================================== EMDIAG1A.139
C MAIN LOOP OVER VERTICAL LEVELS EMDIAG1A.140
C====================================================================== EMDIAG1A.141
C EMDIAG1A.142
DO K=1,P_LEVELS EMDIAG1A.143
C EMDIAG1A.144
C---------------------------------------------------------------------- EMDIAG1A.145
C CALCULATE MASS OF LEVEL K AT EACH GRID POINT AND ALSO EMDIAG1A.146
C P*DELTA_BK AT EACH GRID POINT EMDIAG1A.147
C---------------------------------------------------------------------- EMDIAG1A.148
C EMDIAG1A.149
C EMDIAG1A.150
! Loop over all points, including halos APB5F401.31
DO I=FIRST_VALID_PT,LAST_P_VALID_PT APB5F401.32
PSTAR_DELBK(I) = -DELTA_BK(K)*PSTAR(I) EMDIAG1A.152
DELP_P(I) = -DELTA_AK(K) + PSTAR_DELBK(I) EMDIAG1A.153
END DO EMDIAG1A.154
C EMDIAG1A.155
C---------------------------------------------------------------------- EMDIAG1A.156
C INTERPOLATE DELP_P TO UV GRID EMDIAG1A.157
C---------------------------------------------------------------------- EMDIAG1A.158
C EMDIAG1A.159
CALL P_TO_UV (DELP_P,DELP_UV,P_FIELD,U_FIELD,ROW_LENGTH,ROWS) EMDIAG1A.160
C EMDIAG1A.161
C---------------------------------------------------------------------- EMDIAG1A.162
C CALCULATE RADIUS OF SPHERE AT LEVEL K EMDIAG1A.163
C---------------------------------------------------------------------- EMDIAG1A.164
C EMDIAG1A.165
IF (.NOT.LWHITBROM) THEN GSS1F304.827
C GSS1F304.828
DO I=1,P_FIELD EMDIAG1A.167
RS_P_K(I) = A EMDIAG1A.168
END DO EMDIAG1A.169
C EMDIAG1A.170
DO I=1,U_FIELD EMDIAG1A.171
RS_UV_K(I) = A EMDIAG1A.172
END DO EMDIAG1A.173
C EMDIAG1A.174
ELSE GSS1F304.829
C GSS1F304.830
CALL CALC_RS(PSTAR(FIRST_VALID_PT),AK,BK,TS(FIRST_VALID_PT), APB5F401.33
& WORK(FIRST_VALID_PT),RS_P_K(FIRST_VALID_PT), APB5F401.34
& POINTS,K,P_LEVELS,LLINTS) APB5F401.35
C EMDIAG1A.177
C EMDIAG1A.178
C---------------------------------------------------------------------- EMDIAG1A.179
C INTERPLOATE RADIUS OF SPHERE AT LEVEL K TO UV GRID EMDIAG1A.180
C---------------------------------------------------------------------- EMDIAG1A.181
C EMDIAG1A.182
CALL P_TO_UV (RS_P_K,RS_UV_K,P_FIELD,U_FIELD,ROW_LENGTH,ROWS) EMDIAG1A.183
C EMDIAG1A.184
END IF GSS1F304.833
C EMDIAG1A.186
C---------------------------------------------------------------------- EMDIAG1A.187
C SUM CP*TL OVER GLOBE FOR LEVEL K AND ADD TO TOTAL ENERGY SUM EMDIAG1A.188
C---------------------------------------------------------------------- EMDIAG1A.189
C EMDIAG1A.190
CALL ENERGY_SUM (TL(1,K),START_POINT_NO_HALO, APB5F401.36
& END_P_POINT_NO_HALO,P_FIELD, APB5F401.37
& AREA_P,DELP_P,RS_P_K,CP,TOT_ENERGY) APB5F401.38
C EMDIAG1A.194
C EMDIAG1A.195
C---------------------------------------------------------------------- EMDIAG1A.196
C SUM 0.5*U*U OVER GLOBE FOR LEVEL K AND ADD TO TOTAL ENERGY SUM EMDIAG1A.197
C---------------------------------------------------------------------- EMDIAG1A.198
C EMDIAG1A.199
! Loop over all points except North and South Halos APB5F401.39
DO I=FIRST_FLD_PT,LAST_U_FLD_PT APB5F401.40
WORK(I) = U(I,K)*U(I,K) EMDIAG1A.201
END DO EMDIAG1A.202
C EMDIAG1A.203
CALL ENERGY_SUM (WORK,START_POINT_NO_HALO, APB5F401.41
& END_U_POINT_NO_HALO,U_FIELD, APB5F401.42
& AREA_UV,DELP_UV,RS_UV_K,0.5,TOT_ENERGY) APB5F401.43
C EMDIAG1A.207
C EMDIAG1A.208
C---------------------------------------------------------------------- EMDIAG1A.209
C SUM 0.5*V*V OVER GLOBE FOR LEVEL K AND ADD TO TOTAL ENERGY SUM EMDIAG1A.210
C---------------------------------------------------------------------- EMDIAG1A.211
C EMDIAG1A.212
! Loop over all points except North and South Halos APB5F401.44
DO I=FIRST_FLD_PT,LAST_U_FLD_PT APB5F401.45
WORK(I) = V(I,K)*V(I,K) EMDIAG1A.214
END DO EMDIAG1A.215
C EMDIAG1A.216
CALL ENERGY_SUM (WORK,START_POINT_NO_HALO, APB5F401.46
& END_U_POINT_NO_HALO,U_FIELD, APB5F401.47
& AREA_UV,DELP_UV,RS_UV_K,0.5,TOT_ENERGY) APB5F401.48
C EMDIAG1A.220
C EMDIAG1A.221
C---------------------------------------------------------------------- EMDIAG1A.222
C SUM MASS OF LEVEL K OVER GLOBE AND ADD TO TOTAL ATMOSPHERIC MASS EMDIAG1A.223
C ON THE P_GRID EMDIAG1A.224
C---------------------------------------------------------------------- EMDIAG1A.225
C EMDIAG1A.226
CALL MASS_SUM (DELP_P,RS_P_K,AREA_P, APB5F401.49
& START_POINT_NO_HALO,END_P_POINT_NO_HALO, APB5F401.50
& P_FIELD,TOT_MASS_P) APB5F401.51
C EMDIAG1A.230
C EMDIAG1A.231
C---------------------------------------------------------------------- EMDIAG1A.232
C SUM PSTAR*DELBK FOR LEVEL K OVER THE GLOBE ON THE P GRID EMDIAG1A.233
C---------------------------------------------------------------------- EMDIAG1A.234
C EMDIAG1A.235
CALL MASS_SUM (PSTAR_DELBK,RS_P_K,AREA_P, APB5F401.52
& START_POINT_NO_HALO,END_P_POINT_NO_HALO, APB5F401.53
& P_FIELD,PART_MASS_P) APB5F401.54
C EMDIAG1A.239
IF (LWHITBROM) THEN GSS1F304.834
C EMDIAG1A.241
C---------------------------------------------------------------------- EMDIAG1A.242
C STORE RADIUS OF SPHERE AT LEVEL K INTO WORK TO ALLOW CALCULATION EMDIAG1A.243
C OF RADIUS AT LEVEL K+1 EMDIAG1A.244
C---------------------------------------------------------------------- EMDIAG1A.245
C EMDIAG1A.246
DO I=1,P_FIELD EMDIAG1A.247
WORK(I) = RS_P_K(I) EMDIAG1A.248
END DO EMDIAG1A.249
C EMDIAG1A.250
END IF GSS1F304.835
C EMDIAG1A.252
C====================================================================== EMDIAG1A.253
C END OF MAIN LOOP OVER LEVELS EMDIAG1A.254
C====================================================================== EMDIAG1A.255
C EMDIAG1A.256
END DO EMDIAG1A.257
C EMDIAG1A.258
RETURN EMDIAG1A.259
END EMDIAG1A.260
*ENDIF EMDIAG1A.261