SUBROUTINE INIT_EMCORR( 1,1@DYALLOC.1145
*CALL ARGSIZE 
@DYALLOC.1146
*CALL ARGD1 @DYALLOC.1147
*CALL ARGDUMA @DYALLOC.1148
*CALL ARGPTRA @DYALLOC.1149
*CALL ARGCONA @DYALLOC.1150
& ICODE,CMESSAGE,LLINTS,LWHITBROM) GSS1F304.838
C @DYALLOC.1152
C*---------------------------------------------------------------------- @DYALLOC.1153
IMPLICIT NONE @DYALLOC.1154
LOGICAL LLINTS,LWHITBROM GSS1F304.839
C @DYALLOC.1155
C Subroutines called @DYALLOC.1156
C @DYALLOC.1157
EXTERNAL INIT_EMCORR2 @DYALLOC.1158
C @DYALLOC.1159
C Arguments @DYALLOC.1160
C @DYALLOC.1161
C Configuration-dependent sizes and arrays @DYALLOC.1162
C @DYALLOC.1163
*CALL TYPSIZE @DYALLOC.1164
*CALL TYPD1 @DYALLOC.1165
*CALL TYPDUMA @DYALLOC.1166
*CALL TYPPTRA @DYALLOC.1167
*CALL CMAXSIZE @DYALLOC.1168
*CALL TYPCONA @DYALLOC.1169
C @DYALLOC.1170
*CALL C_MDI @DYALLOC.1171
*IF DEF,MPP APB5F401.72
! Parallel variable common blocks APB5F401.73
*CALL PARVARS APB5F401.74
*ENDIF APB5F401.75
C @DYALLOC.1172
INTEGER ICODE ! Work - Internal return code @DYALLOC.1173
CHARACTER*256 CMESSAGE ! Work - Internal error message @DYALLOC.1174
C @DYALLOC.1175
C Local variables @DYALLOC.1176
C @DYALLOC.1177
*CALL TYPFLDPT APB5F401.76
C @DYALLOC.1180
IF(A_REALHD(19).EQ.RMDI .OR. @DYALLOC.1181
* A_REALHD(20).EQ.RMDI .OR. @DYALLOC.1182
* A_REALHD(21).EQ.RMDI) THEN @DYALLOC.1183
C @DYALLOC.1184
! Calculate TYPFLDPT variables to pass down for ENG_MASS_DIAG APB5F401.77
*CALL SETFLDPT APB5F401.78
C @DYALLOC.1186
CALL INIT_EMCORR2( P_FIELD,U_FIELD,ROW_LENGTH, APB5F401.79
& P_ROWS,P_LEVELS,Q_LEVELS,D1(JTHETA(1)), @DYALLOC.1188
& D1(JQCL(1)),D1(JQCF(1)),D1(JU(1)), @DYALLOC.1189
& D1(JV(1)),D1(JPSTAR),D1(JP_EXNER(1)), @DYALLOC.1190
& COS_P_LATITUDE,COS_U_LATITUDE, @DYALLOC.1191
& A_LEVDEPC(JDELTA_AK), @DYALLOC.1192
& A_LEVDEPC(JDELTA_BK), @DYALLOC.1193
& A_LEVDEPC(JAK),A_LEVDEPC(JBK),AKH,BKH, @DYALLOC.1194
& A_REALHD(18),A_REALHD(19),A_REALHD(20), @DYALLOC.1195
& A_REALHD(21), APB5F401.80
*CALL ARGFLDPT APB5F401.81
& LLINTS,LWHITBROM) APB5F401.82
ENDIF @DYALLOC.1197
C @DYALLOC.1198
RETURN @DYALLOC.1199
END @DYALLOC.1200
CLL SUBROUTINE INIT_EMCORR2----------------------------------------- @DYALLOC.1201
CLL INEMCR1A.4
CLL PURPOSE : PART OF ENERGY CORRECTION SUITE OF ROUTINES INEMCR1A.5
CLL - TO INITIALISE ENERGY CORRECTION AT INEMCR1A.6
CLL START OF A NEW INTEGRATION INEMCR1A.7
CLL NOT SUITABLE FOR SINGLE COLUMN MODEL USE INEMCR1A.8
CLL INEMCR1A.9
CLL CODE WRITTEN FOR CRAY Y-MP BY D.GREGORY NOVEMBER 1991 INEMCR1A.10
CLL INEMCR1A.11
CLL MODEL MODIFICATION HISTORY FROM MODEL VERSION 3.0: INEMCR1A.12
CLL VERSION DATE INEMCR1A.13
CLL 3.2 30/03/93 Redefine INIT_EMCORR to become a new routine @DYALLOC.1202
CLL INIT_EMCORR2 and introduce a control interface @DYALLOC.1203
CLL routine INIT_EMCORR for dynamic allocation of @DYALLOC.1204
CLL main data arrays. @DYALLOC.1205
CLL 3.4 23/06/94 Arguments LLINTS, LWHITBROM added and passed to GSS1F304.841
CLL ENG_MASS_DIAG S.J.Swarbrick GSS1F304.842
!LL 4.1 23/04/96 Added TYPFLDPT arguments to pass down to APB5F401.83
! ENG_MASS_DIAG P.Burton APB5F401.84
CLL INEMCR1A.14
CLL PROGRAMMING STANDARDS : UNIFIED MODEL DOCUMENTATION PAPER NO. 4 INEMCR1A.15
CLL VERSION NO. 1 INEMCR1A.16
CLL INEMCR1A.17
CLL SYSTEM TASK : P## INEMCR1A.18
CLL INEMCR1A.19
CLL DOCUMENTATION : UNIFIED MODEL DOCUMENTATION PAPER P### INEMCR1A.20
CLL INEMCR1A.21
CLLEND----------------------------------------------------------------- INEMCR1A.22
C INEMCR1A.23
C*L ARGUMENTS--------------------------------------------------------- INEMCR1A.24
C INEMCR1A.25
SUBROUTINE INIT_EMCORR2(P_FIELD,U_FIELD,ROW_LENGTH, 1,1APB5F401.85
& P_ROWS,P_LEVELS,Q_LEVELS,THETA,QCL,QCF, INEMCR1A.27
& U,V,PSTAR,EXNER,AREA_P,AREA_UV,DELTA_AK, INEMCR1A.28
& DELTA_BK,AK,BK,AKH,BKH,TOT_FLUXES, INEMCR1A.29
& TOT_MASS_P,TOT_ENERGY,ENERGY_CORR, APB5F401.86
*CALL ARGFLDPT APB5F401.87
& LLINTS,LWHITBROM) APB5F401.88
C INEMCR1A.31
IMPLICIT NONE INEMCR1A.32
LOGICAL LLINTS,LWHITBROM GSS1F304.845
*CALL C_R_CP INEMCR1A.33
*CALL C_LHEAT INEMCR1A.34
C INEMCR1A.35
C---------------------------------------------------------------------- INEMCR1A.36
C VECTOR LENGTHS AND START ADDRESSES INEMCR1A.37
C---------------------------------------------------------------------- INEMCR1A.38
C INEMCR1A.39
C INEMCR1A.40
INTEGER P_FIELD ! IN VECTOR LENGTH OF VARIABLES ON INEMCR1A.41
! P GRID INEMCR1A.42
C INEMCR1A.43
INTEGER U_FIELD ! IN VECTOR LENGTH OF VARIABLES ON INEMCR1A.44
! UV GRID INEMCR1A.45
C INEMCR1A.46
C INEMCR1A.49
INTEGER ROW_LENGTH ! IN NUMBER OF POINTS PER ROW INEMCR1A.50
C INEMCR1A.51
INTEGER P_ROWS ! IN NUMBER OF ROWS IN P GRID INEMCR1A.52
C INEMCR1A.53
INTEGER P_LEVELS ! IN NUMBER OF LEVELS IN VERTICAL INEMCR1A.54
C INEMCR1A.55
INTEGER Q_LEVELS ! IN NUMBER OF LEVELS WITH MOISTURE INEMCR1A.56
C INEMCR1A.57
! All TYPFLDPT arguments are intent IN APB5F401.89
*CALL TYPFLDPT APB5F401.90
C INEMCR1A.58
C---------------------------------------------------------------------- INEMCR1A.59
C VARIABLES WHICH ARE INPUT INEMCR1A.60
C---------------------------------------------------------------------- INEMCR1A.61
C INEMCR1A.62
REAL THETA(P_FIELD,P_LEVELS) ! IN TEMPERATURE INEMCR1A.63
C INEMCR1A.64
REAL QCL(P_FIELD,P_LEVELS) ! IN CLOUD LIQUID WATER INEMCR1A.65
C INEMCR1A.66
REAL QCF(P_FIELD,P_LEVELS) ! IN CLOUD ICE INEMCR1A.67
C INEMCR1A.68
REAL U(U_FIELD,P_LEVELS) ! IN COMPONENT OF WIND INEMCR1A.69
C INEMCR1A.70
REAL V(U_FIELD,P_LEVELS) ! IN COMPONENT OF WIND INEMCR1A.71
C INEMCR1A.72
REAL AREA_P(P_FIELD) ! IN AREA OF CELLS IN P GRID INEMCR1A.73
C INEMCR1A.74
REAL AREA_UV(U_FIELD) ! IN AREA OF CELLS IN UV GRID INEMCR1A.75
C INEMCR1A.76
REAL DELTA_AK(P_LEVELS) ! IN |THICKNESS OF LAYERS IN INEMCR1A.77
C | INEMCR1A.78
REAL DELTA_BK(P_LEVELS) ! IN |ETA CO-ORDINATES INEMCR1A.79
C INEMCR1A.80
REAL AK(P_LEVELS) ! IN |ETA CO-ORDINATES OF INEMCR1A.81
C | INEMCR1A.82
REAL BK(P_LEVELS) ! IN |MID-LAYER POINTS INEMCR1A.83
C INEMCR1A.84
REAL AKH(P_LEVELS+1) ! IN |ETA CO-ORDINATES AT INEMCR1A.85
C | INEMCR1A.86
REAL BKH(P_LEVELS+1) ! IN |LAYER BOUNDARIES INEMCR1A.87
C INEMCR1A.88
REAL PSTAR(P_FIELD) ! IN PRESSURE AT SURFACE INEMCR1A.89
C INEMCR1A.90
REAL EXNER(P_FIELD,P_LEVELS+1) ! IN EXNER FUNCTION INEMCR1A.91
C INEMCR1A.92
C INEMCR1A.93
C---------------------------------------------------------------------- INEMCR1A.94
C VARIABLES WHICH ARE IN AND OUT INEMCR1A.95
C---------------------------------------------------------------------- INEMCR1A.96
C INEMCR1A.97
REAL ENERGY_CORR ! RATE OF TEMPERATURE RISE PER INEMCR1A.98
! SECOND TO COMPENSATE ENERGY LOSS INEMCR1A.99
C INEMCR1A.100
REAL TOT_ENERGY ! TOTAL ENERGY OF ATMOSPHERE INEMCR1A.101
C INEMCR1A.102
REAL TOT_MASS_P ! TOTAL MASS OF ATMOSPHERE INEMCR1A.103
C INEMCR1A.104
REAL TOT_FLUXES ! TOTAL DIABATIC FLUXES IN TO INEMCR1A.105
! ATMOSPHERE OVER A TIMESTEP INEMCR1A.106
C INEMCR1A.107
C INEMCR1A.108
C---------------------------------------------------------------------- INEMCR1A.109
C VARIABLES WHICH ARE DEFINED LOCALLY INEMCR1A.110
C---------------------------------------------------------------------- INEMCR1A.111
C INEMCR1A.112
REAL PART_MASS_P ! PARTIAL MASS OF ATMOSPHERE INEMCR1A.113
C INEMCR1A.114
C INEMCR1A.115
C---------------------------------------------------------------------- INEMCR1A.116
C INTERNAL LOOP COUNTERS INEMCR1A.117
C---------------------------------------------------------------------- INEMCR1A.118
C INEMCR1A.119
INTEGER I ! LOOP COUNTER INEMCR1A.120
C INEMCR1A.121
INTEGER J ! LOOP COUNTER INEMCR1A.122
C INEMCR1A.123
C INEMCR1A.124
C---------------------------------------------------------------------- INEMCR1A.125
C EXTERNAL SUBROUTINE CALLS - TIMER,ENG_MASS_DIAG INEMCR1A.126
C---------------------------------------------------------------------- INEMCR1A.127
C INEMCR1A.128
EXTERNAL TIMER,ENG_MASS_DIAG INEMCR1A.129
C INEMCR1A.130
C VARIABLES USED IN CONVERSION OF T TO THETA AND VICE VERSA INEMCR1A.131
C INEMCR1A.132
REAL INEMCR1A.133
& PU,PL INEMCR1A.134
*CALL P_EXNERC INEMCR1A.135
C INEMCR1A.136
C*--------------------------------------------------------------------- INEMCR1A.137
C INEMCR1A.138
C CONVERT THETA TO TL (OR T) INEMCR1A.139
C INEMCR1A.140
IF(P_LEVELS.EQ.Q_LEVELS)THEN INEMCR1A.141
C INEMCR1A.142
DO J=1,P_LEVELS INEMCR1A.143
! Loop over all points, not including halos APB5F401.91
DO I=FIRST_FLD_PT,LAST_P_FLD_PT APB5F401.92
PU = PSTAR(I)*BKH(J+1) + AKH(J+1) INEMCR1A.145
PL = PSTAR(I)*BKH(J) + AKH(J) INEMCR1A.146
THETA(I,J) = (THETA(I,J) * INEMCR1A.147
& P_EXNER_C(EXNER(I,J+1),EXNER(I,J),PU,PL,KAPPA)) INEMCR1A.148
& - ((LC*QCL(I,J) + (LC+LF)*QCF(I,J))/CP) INEMCR1A.149
END DO INEMCR1A.150
END DO INEMCR1A.151
C INEMCR1A.152
ELSE INEMCR1A.153
C INEMCR1A.154
DO J=1,Q_LEVELS INEMCR1A.155
! Loop over all points, not including halos APB5F401.93
DO I=FIRST_FLD_PT,LAST_P_FLD_PT APB5F401.94
PU = PSTAR(I)*BKH(J+1) + AKH(J+1) INEMCR1A.157
PL = PSTAR(I)*BKH(J) + AKH(J) INEMCR1A.158
THETA(I,J) = (THETA(I,J) * INEMCR1A.159
& P_EXNER_C(EXNER(I,J+1),EXNER(I,J),PU,PL,KAPPA)) INEMCR1A.160
& - ((LC*QCL(I,J) + (LC+LF)*QCF(I,J))/CP) INEMCR1A.161
END DO INEMCR1A.162
END DO INEMCR1A.163
C INEMCR1A.164
DO J=Q_LEVELS+1,P_LEVELS INEMCR1A.165
! Loop over all points, not including halos APB5F401.95
DO I=FIRST_FLD_PT,LAST_P_FLD_PT APB5F401.96
PU = PSTAR(I)*BKH(J+1) + AKH(J+1) INEMCR1A.167
PL = PSTAR(I)*BKH(J) + AKH(J) INEMCR1A.168
THETA(I,J) = THETA(I,J) * INEMCR1A.169
& P_EXNER_C(EXNER(I,J+1),EXNER(I,J),PU,PL,KAPPA) INEMCR1A.170
END DO INEMCR1A.171
END DO INEMCR1A.172
C INEMCR1A.173
END IF INEMCR1A.174
C INEMCR1A.175
C CALCULATE MODIFIED TOTAL ENERGY AND MASS OF ATMOSPHERE INEMCR1A.176
C INEMCR1A.177
C INEMCR1A.178
C ZERO TOTAL ENERGY AND MASS BEFORE CALCULATION INEMCR1A.179
C INEMCR1A.180
TOT_MASS_P = 0.0 INEMCR1A.181
TOT_ENERGY = 0.0 INEMCR1A.182
PART_MASS_P = 0.0 INEMCR1A.183
C INEMCR1A.184
CALL ENG_MASS_DIAG (THETA,U,V,AREA_P,AREA_UV,P_FIELD,U_FIELD, INEMCR1A.185
& ROW_LENGTH,P_ROWS,DELTA_AK, APB5F401.97
& DELTA_BK,AK,BK,TOT_ENERGY,TOT_MASS_P, INEMCR1A.187
& PART_MASS_P,P_LEVELS,PSTAR, APB5F401.98
*CALL ARGFLDPT APB5F401.99
& LLINTS,LWHITBROM) APB5F401.100
C INEMCR1A.189
C INEMCR1A.190
C INITIAL RATE OF ENERGY CORRECTION TO ZERO INEMCR1A.191
C INEMCR1A.192
ENERGY_CORR = 0.0 INEMCR1A.193
C INEMCR1A.194
C ZERO ACCULATED DIABATIC FLUXES INEMCR1A.195
C INEMCR1A.196
TOT_FLUXES = 0.0 INEMCR1A.197
C INEMCR1A.198
C CONVERT TL (OR T) TO THETA INEMCR1A.199
C INEMCR1A.200
IF(P_LEVELS.EQ.Q_LEVELS)THEN INEMCR1A.201
C INEMCR1A.202
DO J=1,P_LEVELS INEMCR1A.203
! Loop over all points, not including halos APB5F401.101
DO I=FIRST_FLD_PT,LAST_P_FLD_PT APB5F401.102
PU = PSTAR(I)*BKH(J+1) + AKH(J+1) INEMCR1A.205
PL = PSTAR(I)*BKH(J) + AKH(J) INEMCR1A.206
THETA(I,J) = (THETA(I,J) + INEMCR1A.207
& ((LC*QCL(I,J)+(LC+LF)*QCF(I,J))/CP)) / INEMCR1A.208
& P_EXNER_C(EXNER(I,J+1),EXNER(I,J),PU,PL,KAPPA) INEMCR1A.209
END DO INEMCR1A.210
END DO INEMCR1A.211
C INEMCR1A.212
ELSE INEMCR1A.213
C INEMCR1A.214
DO J=1,Q_LEVELS INEMCR1A.215
! Loop over all points, not including halos APB5F401.103
DO I=FIRST_FLD_PT,LAST_P_FLD_PT APB5F401.104
PU = PSTAR(I)*BKH(J+1) + AKH(J+1) INEMCR1A.217
PL = PSTAR(I)*BKH(J) + AKH(J) INEMCR1A.218
THETA(I,J) = (THETA(I,J) + INEMCR1A.219
& ((LC*QCL(I,J)+(LC+LF)*QCF(I,J))/CP)) / INEMCR1A.220
& P_EXNER_C(EXNER(I,J+1),EXNER(I,J),PU,PL,KAPPA) INEMCR1A.221
END DO INEMCR1A.222
END DO INEMCR1A.223
C INEMCR1A.224
DO J=Q_LEVELS+1,P_LEVELS INEMCR1A.225
! Loop over all points, not including halos APB5F401.105
DO I=FIRST_FLD_PT,LAST_P_FLD_PT APB5F401.106
PU = PSTAR(I)*BKH(J+1) + AKH(J+1) INEMCR1A.227
PL = PSTAR(I)*BKH(J) + AKH(J) INEMCR1A.228
THETA(I,J) = THETA(I,J) / INEMCR1A.229
& P_EXNER_C(EXNER(I,J+1),EXNER(I,J),PU,PL,KAPPA) INEMCR1A.230
END DO INEMCR1A.231
END DO INEMCR1A.232
C INEMCR1A.233
END IF INEMCR1A.234
C INEMCR1A.235
RETURN INEMCR1A.236
END INEMCR1A.237
*ENDIF INEMCR1A.238