*IF DEF,A10_1A,OR,DEF,A10_1B ATJ0F402.1
*IF -DEF,SCMA AJC0F405.257
C ******************************COPYRIGHT****************************** GTS2F400.199
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.200
C GTS2F400.201
C Use, duplication or disclosure of this code is subject to the GTS2F400.202
C restrictions as set forth in the contract. GTS2F400.203
C GTS2F400.204
C Meteorological Office GTS2F400.205
C London Road GTS2F400.206
C BRACKNELL GTS2F400.207
C Berkshire UK GTS2F400.208
C RG12 2SZ GTS2F400.209
C GTS2F400.210
C If no contract has been raised with this copy of the code, the use, GTS2F400.211
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.212
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.213
C Modelling at the above address. GTS2F400.214
C ******************************COPYRIGHT****************************** GTS2F400.215
C GTS2F400.216
CLL SUBROUTINE ADJ_CTL --------------------------------------------- ADJCTL1A.3
CLL ADJCTL1A.4
CLL PURPOSE: INTEGRATES SURFACE PRESSURE, POTENTIAL TEMPERATURE, ADJCTL1A.5
CLL AND HORIZONTAL WIND COMPONENTS THROUGH A SPECIFIED ADJCTL1A.6
CLL NUMBER OF ADJUSTMENT STEPS. AT THE END OF THE ROUTINE ADJCTL1A.7
CLL UPDATED VALUES OF ALL THESE FIELDS ALONG WITH THE ADJCTL1A.8
CLL UPDATED EXNER PRESSURE ARE HELD IN THE ARGUMENTS. ADJCTL1A.9
CLL FOURIER FILTERING IS PERFORMED UNDER THE ADJCTL1A.10
CLL UPDATE IDENTIFIER 'GLOBAL'. ONE MORE PRESSURE ROW IS ADJCTL1A.11
CLL UPDATED THAN VELOCITY ROW. ADJCTL1A.12
CLL FIRST_ROW IS NORTHERNMOST PRESSURE ROW TO BE UPDATED. ADJCTL1A.13
CLL FIRST_U_ROW UPDATED IS THE FIRST ONE TO THE SOUTH OF ADJCTL1A.14
CLL THE FIRST P ROW. ADJCTL1A.15
CLL NOT SUITABLE FOR SINGLE COLUMN USE. ADJCTL1A.16
CLL VERSION FOR CRAY Y-MP ADJCTL1A.17
CLL WRITTEN BY M.H MAWSON. ADJCTL1A.18
CLL ADJCTL1A.19
CLL MODEL MODIFICATION HISTORY FROM MODEL VERSION 3.0: ADJCTL1A.20
CLL VERSION DATE ADJCTL1A.21
CLL 3.1 24/02/93 Tidy code to remove QA Fortran messages. MM240293.10
CLL 3.2 13/07/93 Changed CHARACTER*(*) to CHARACTER*(80) for TS150793.4
CLL portability. Author: Tracey Smith. TS150793.5
CLL 3.4 22/06/94 Arguments LLINTS, LWHITBROM added and passed to GSS1F304.778
CLL VERT_VEL, UV_ADJ GSS1F304.779
CLL S.J.Swarbrick GSS1F304.780
CLL ADJCTL1A.22
CLL 3.4 06/08/94 Micro tasking directives inserted to improve AAD2F304.118
CLL parallel efficiency on C90. AAD2F304.119
CLL Authors: A. Dickinson, D. Salmond AAD2F304.120
CLL Reviewer: M. Mawson AAD2F304.121
! 3.5 28/03/95 MPP code: Change updateable area, add halo APB0F305.118
! updates. P.Burton APB0F305.119
! 4.1 02/04/96 Added TYPFLDPT arguments to dynamics routines APB0F401.138
! which allows many of the differences between APB0F401.139
! MPP and "normal" code to be at top level APB0F401.140
! Added LEVELS argument to POLAR_UV APB0F401.141
! P.Burton APB0F401.142
!LL 4.2 16/08/96 Add TYPFLDPT arguments to FILTER subroutine APB0F402.1
!LL and make the FILTER_WAVE_NUMBER arrays APB0F402.2
!LL globally sized P.Burton APB0F402.3
!LL 4.2 25/11/96 Corrections to allow LAM to run in MPP mode. ARB2F402.38
!LL RTHBarnes. ARB2F402.39
! 4.2 Oct. 96 T3E migration: *DEF CRAY removed; HF functions GSS4F402.13
! replaced by T3E rtor_v funtion (*DEF T3E) GSS4F402.14
! code restructured appropriately. GSS4F402.15
! S.J.Swarbrick GSS4F402.16
C vn4.3 Mar. 97 T3E migration : optimisation changes GSS1F403.1046
C D.Salmond GSS1F403.1047
! 4.5 23/10/98 Introduce Single Column Model. JC Thil AJC0F405.256
! 4.5 12/05/98 Replace **k by exp(k*log( )) for faster running GRB1F405.34
! on Fujitsu VPP700. RBarnes@ecmwf.int GRB1F405.35
CLL AAD2F304.122
CLL PROGRAMMING STANDARD: UNIFIED MODEL DOCUMENTATION PAPER NO. 4, ADJCTL1A.23
CLL STANDARD B, VERSION 2, DATED 18/01/90 ADJCTL1A.24
CLL SYSTEM COMPONENTS COVERED: P11 ADJCTL1A.25
CLL SYSTEM TASK: P1 ADJCTL1A.26
CLL DOCUMENTATION: THE EQUATIONS USED ARE (23) TO (30) ADJCTL1A.27
CLL IN UNIFIED MODEL DOCUMENTATION PAPER NO. 10 ADJCTL1A.28
CLL M.J.P. CULLEN,T.DAVIES AND M.H.MAWSON, ADJCTL1A.29
CLLEND------------------------------------------------------------- ADJCTL1A.30
ADJCTL1A.31
C*L ARGUMENTS:--------------------------------------------------- ADJCTL1A.32
ADJCTL1A.33
SUBROUTINE ADJ_CTL 1,28ADJCTL1A.34
1 (U,V,THETA,Q,PSTAR,OROG_HEIGHT,RS,U_MEAN,V_MEAN,P_EXNER, ADJCTL1A.35
2 ETADOT_MEAN,PSTAR_OLD,COS_P_LATITUDE,COS_U_LATITUDE, ADJCTL1A.36
3 SEC_P_LATITUDE,SEC_U_LATITUDE,TAN_U_LATITUDE,F1,F2,F3, ADJCTL1A.37
4 LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE,AK,BK,DELTA_AK, ADJCTL1A.38
5 DELTA_BK,THETA_REF,ADJUSTMENT_TIMESTEP,ADJUSTMENT_STEPS, ADJCTL1A.39
6 NORTHERN_FILTERED_P_ROW,SOUTHERN_FILTERED_P_ROW,ROW_LENGTH, ADJCTL1A.40
7 P_LEVELS,Q_LEVELS, APB0F401.143
*CALL ARGFLDPT 
APB0F401.144
7 P_FIELD,U_FIELD,AKH,BKH, APB0F401.145
8 AKH_TO_THE_KAPPA,BKH_TO_THE_KAPPA,AK_TO_THE_KAPPA, ADJCTL1A.42
9 BK_TO_THE_KAPPA,COS_U_LONGITUDE, ADJCTL1A.43
* SIN_U_LONGITUDE,TRIGS,IFAX,FILTER_WAVE_NUMBER_P_ROWS, ADJCTL1A.44
* FILTER_WAVE_NUMBER_U_ROWS,ERROR_CODE,ERROR_MESSAGE, ADJCTL1A.45
& L_NEG_PSTAR,PHI_OUT,L_PHI_OUT,ADJ_TIME_SMOOTHING_WEIGHT, ADJCTL1A.46
& ADJ_TIME_SMOOTHING_COEFF,LLINTS,LWHITBROM) GSS1F304.781
ADJCTL1A.48
IMPLICIT NONE ADJCTL1A.49
ADJCTL1A.50
LOGICAL ADJCTL1A.51
* L_NEG_PSTAR !IN SWITCH, IF TRUE THEN NEGATIVE PSTAR VALUES ADJCTL1A.52
* ! WILL BE DETECTED AND OUTPUT. ADJCTL1A.53
*, L_PHI_OUT !IN. IF TRUE THEN PHI REQUIRED AS OUTPUT. ADJCTL1A.54
*, LLINTS !Logical switch for linear TS GSS1F304.782
*, LWHITBROM !Logical switch for White & Bromley terms GSS1F304.783
ADJCTL1A.55
INTEGER ADJCTL1A.56
* P_FIELD !IN DIMENSION OF FIELDS ON PRESSSURE GRID. ADJCTL1A.57
*, U_FIELD !IN DIMENSION OF FIELDS ON VELOCITY GRID ADJCTL1A.58
*, P_LEVELS !IN NUMBER OF PRESSURE LEVELS TO BE UPDATED. ADJCTL1A.61
*, Q_LEVELS !IN NUMBER OF MOIST LEVELS TO BE UPDATED. ADJCTL1A.62
*, ROW_LENGTH !IN NUMBER OF POINTS PER ROW ADJCTL1A.64
*, ADJUSTMENT_STEPS !IN NUMBER OF ADJUSTMENT STEPS ADJCTL1A.65
! All TYPFLDPT arguments are intent IN APB0F401.146
*CALL TYPFLDPT APB0F401.147
ADJCTL1A.66
INTEGER ADJCTL1A.67
* ERROR_CODE !INOUT. 0 ON ENTRY. NON-ZERO ON OUT IF ADJCTL1A.68
* ! ABNORMAL RESULT OBTAINED. ADJCTL1A.69
ADJCTL1A.70
CHARACTER*80 ERROR_MESSAGE TS150793.6
ADJCTL1A.74
INTEGER ADJCTL1A.75
* NORTHERN_FILTERED_P_ROW !IN P ROW ON WHICH FILTERING STOPS ADJCTL1A.76
* ! MOVING TOWARDS EQUATOR ADJCTL1A.77
*, SOUTHERN_FILTERED_P_ROW !IN P ROW ON WHICH FILTERING STARTS ADJCTL1A.78
* ! AGAIN MOVING TOWARDS SOUTH POLE ADJCTL1A.79
&, FILTER_WAVE_NUMBER_P_ROWS(GLOBAL_P_FIELD/GLOBAL_ROW_LENGTH) APB0F402.4
& ! LAST WAVE NUMBER NOT TO BE CHOPPED ON A P ROW APB0F402.5
&, FILTER_WAVE_NUMBER_U_ROWS(GLOBAL_U_FIELD/GLOBAL_ROW_LENGTH) APB0F402.6
& ! LAST WAVE NUMBER NOT TO BE CHOPPED ON A U ROW APB0F402.7
*, IFAX(10) !IN HOLDS FACTORS OF ROW_LENGTH USED BY ADJCTL1A.84
* ! FILTERING. ADJCTL1A.85
*,ADJ_TIME_SMOOTHING_WEIGHT(ADJUSTMENT_STEPS) !IN COEFFICIENTS FOR ADJCTL1A.86
* ! FINITE DIFFERENCE SMOOTHING DERIVATIVE ADJCTL1A.87
ADJCTL1A.88
REAL ADJCTL1A.89
* U(U_FIELD,P_LEVELS) !INOUT U FIELD ADJCTL1A.90
*,V(U_FIELD,P_LEVELS) !INOUT V FIELD ADJCTL1A.91
*,THETA(P_FIELD,P_LEVELS)!INOUT THETA FIELD ADJCTL1A.92
*,P_EXNER(P_FIELD,P_LEVELS+1)!INOUT EXNER PRESSURE FIELD. ADJCTL1A.93
*,Q(P_FIELD,Q_LEVELS) !INOUT Q FIELD ADJCTL1A.94
*,PSTAR(P_FIELD) !INOUT PSTAR FIELD ADJCTL1A.95
ADJCTL1A.96
REAL ADJCTL1A.97
* U_MEAN(U_FIELD,P_LEVELS) !OUT HOLDS MASS-WEIGHTED U ADJCTL1A.98
* ! AVERAGED OVER ADJUSTMENT STEPS. ADJCTL1A.99
*,V_MEAN(U_FIELD,P_LEVELS) !OUT HOLDS MASS-WEIGHTED V*COS(PHI) ADJCTL1A.100
* ! AVERAGED OVER ADJUSTMENT STEPS. ADJCTL1A.101
*,ETADOT_MEAN(P_FIELD,P_LEVELS) !OUT HOLDS MASS-WEIGHTED VERTICAL ADJCTL1A.102
* ! VELOCITY AVERAGED OVER ADJUSTMENT ADJCTL1A.103
* ! STEPS. ADJCTL1A.104
*,PSTAR_OLD(P_FIELD) !OUT HOLDS VALUE OF PSTAR ON PREVIOUS ADJCTL1A.105
* ! TIMESTEP ADJCTL1A.106
*,RS(P_FIELD,P_LEVELS) !OUT RS FIELD ADJCTL1A.107
*,PHI_OUT(P_FIELD,P_LEVELS) !OUT. HOLDS PHI IF DIAGNOSTIC ADJCTL1A.108
* ! REQUIRED. ADJCTL1A.109
ADJCTL1A.110
REAL ADJCTL1A.111
* DELTA_AK(P_LEVELS) !IN LAYER THICKNESS ADJCTL1A.112
*,DELTA_BK(P_LEVELS) !IN LAYER THICKNESS ADJCTL1A.113
*,AK(P_LEVELS) !IN VALUE OF A AT P POINTS ADJCTL1A.114
*,BK(P_LEVELS) !IN VALUE OF B AT P POINTS ADJCTL1A.115
*,AK_TO_THE_KAPPA(P_LEVELS)!IN (A/100000)**(R/CP) AT FULL LEVELS ADJCTL1A.116
*,BK_TO_THE_KAPPA(P_LEVELS)!IN (B/100000)**(R/CP) AT FULL LEVELS ADJCTL1A.117
*,AKH(P_LEVELS+1) !IN VALUE OF A AT HALF LEVELS. ADJCTL1A.118
*,BKH(P_LEVELS+1) !IN VALUE OF B AT HALF LEVELS. ADJCTL1A.119
*,AKH_TO_THE_KAPPA(P_LEVELS+1)!IN (A/100000)**(R/CP) ADJCTL1A.120
* !AT HALF LEVELS ADJCTL1A.121
*,BKH_TO_THE_KAPPA(P_LEVELS+1)!IN (B/100000)**(R/CP) ADJCTL1A.122
* !AT HALF LEVELS ADJCTL1A.123
*,OROG_HEIGHT(P_FIELD) !IN OROGRAPHIC HEIGHT. ADJCTL1A.124
ADJCTL1A.125
REAL ADJCTL1A.126
* F1(U_FIELD) !IN A CORIOLIS TERM SEE DOCUMENTATION ADJCTL1A.127
*,F2(U_FIELD) !IN A CORIOLIS TERM SEE DOCUMENTATION ADJCTL1A.128
*,F3(U_FIELD) !IN A CORIOLIS TERM SEE DOCUMENTATION ADJCTL1A.129
*,COS_U_LATITUDE(U_FIELD) !IN COS(LAT) AT U POINTS (2-D ARRAY) ADJCTL1A.130
*,COS_P_LATITUDE(P_FIELD) !IN COS(LAT) AT P POINTS (2-D ARRAY) ADJCTL1A.131
*,SEC_U_LATITUDE(U_FIELD) !IN 1/COS(LAT) AT U POINTS (2-D ARRAY) ADJCTL1A.132
*,SEC_P_LATITUDE(P_FIELD) !IN 1/COS(LAT) AT P POINTS (2-D ARRAY) ADJCTL1A.133
*,TAN_U_LATITUDE(U_FIELD) !IN TAN(LAT) AT U POINTS (2-D ARRAY) ADJCTL1A.134
*,COS_U_LONGITUDE(ROW_LENGTH) !IN COS(LONGITUDE) AT U POINTS ADJCTL1A.135
*,SIN_U_LONGITUDE(ROW_LENGTH) !IN SIN(LONGITUDE) AT U POINTS ADJCTL1A.136
ADJCTL1A.137
REAL ADJCTL1A.138
* THETA_REF(P_LEVELS) !IN REFERENCE THETA PROFILE ADJCTL1A.139
*,LONGITUDE_STEP_INVERSE !IN 1/LONGITUDE INCREMENT IN RADIANS ADJCTL1A.140
*,LATITUDE_STEP_INVERSE !IN 1/LATITUDE INCREMENT IN RADIANS ADJCTL1A.141
*,ADJUSTMENT_TIMESTEP !IN ADJCTL1A.142
&,ADJ_TIME_SMOOTHING_COEFF !IN COEFFICIENT. ZERO = NO SMOOTHING ADJCTL1A.143
*,TRIGS(ROW_LENGTH) !IN HOLDS TRIGONOMETRIC FUNCTIONS USED ADJCTL1A.144
* ! IN FILTERING. ADJCTL1A.145
ADJCTL1A.146
C*--------------------------------------------------------------------- ADJCTL1A.147
ADJCTL1A.148
C*L DEFINE ARRAYS AND VARIABLES USED IN THIS ROUTINE----------------- ADJCTL1A.149
C DEFINE LOCAL ARRAYS: 6 ARE REQUIRED IF TIME SMOOTHING ADJCTL1A.150
REAL ADJCTL1A.151
* RS_DELTAP(P_FIELD) !HOLDS RS * VERTICAL PRESSURE DIFFERENCE ADJCTL1A.152
* !AT P POINTS. ADJCTL1A.153
*,DIVERGENCE_FUNCTIONS(P_FIELD,P_LEVELS) !WORKSPACE FOR HOLDING ADJCTL1A.154
* !QUANTITIES INVOLVING DIVERGENCE ADJCTL1A.155
*,RS_DELTAP_UV(U_FIELD) !HOLDS RS_DELTAP AT U POINTS. ADJCTL1A.156
*,RECIP_RS_SQUARED_SURFACE(P_FIELD) !HOLDS 1/(RS*RS) CALCULATED AT ADJCTL1A.157
* ! MODEL SURFACE. ADJCTL1A.158
&,U_SMOOTH(U_FIELD,P_LEVELS) ! IN ACCUMULATES U DURING ADJUSTMENT ADJCTL1A.159
&,V_SMOOTH(U_FIELD,P_LEVELS) ! IN ACCUMULATES V DURING ADJUSTMENT ADJCTL1A.160
ADJCTL1A.161
C*--------------------------------------------------------------------- ADJCTL1A.162
C DEFINE LOCAL VARIABLES ADJCTL1A.163
INTEGER ADJCTL1A.164
* NORTHERN_FILTERED_U_ROW ! U ROW ON WHICH FITERING STOPS MOVING APB0F401.148
* ! TOWARDS EQUATOR. ADJCTL1A.174
*, SOUTHERN_FILTERED_U_ROW ! U ROW ON WHICH FILTERING STARTS AGAIN ADJCTL1A.175
* ! MOVING TOWARDS SOUTH POLE. ADJCTL1A.176
ADJCTL1A.177
INTEGER ADJCTL1A.178
* I ADJCTL1A.179
*, K ADJCTL1A.180
*, ADJ_STEP_NUMBER ! USED TO HOLD THE NUMBER OF THE ADJCTL1A.181
* ! ADJUSTMENT STEP BEING EXECUTED. ADJCTL1A.182
*, FILTER_SPACE_U ! HORIZONTAL DIMENSION OF SPACE NEEDED IN ADJCTL1A.183
* ! FILTERING ROUTINE FOR U ROWS. ADJCTL1A.184
*, FILTER_SPACE_P ! HORIZONTAL DIMENSION OF SPACE NEEDED IN ADJCTL1A.185
* ! FILTERING ROUTINE FOR P ROWS. ADJCTL1A.186
ADJCTL1A.187
REAL ADJCTL1A.188
* RECIP_RS_DELTAP ! HOLDS 1./RS_DELTAP ADJCTL1A.189
*, RECIP_PREF ! 1/PREF ADJCTL1A.191
*, RECIP_PREF_TO_THE_KAPPA ! 1/PREF ** KAPPA ADJCTL1A.193
*, RECIP_ADJUSTMENT_STEPS ADJCTL1A.195
*, SCALAR ADJCTL1A.196
C Local workspace arrays used in T3E restructured code GSS4F402.17
REAL EXNER_wk(LAST_P_VALID_PT-FIRST_VALID_PT+1) GSS4F402.18
! No. of inputs for T3E vector library function GSS4F402.20
integer n_inputs GSS4F402.21
ADJCTL1A.198
C*L EXTERNAL SUBROUTINE CALLS:--------------------------------------- ADJCTL1A.199
EXTERNAL UV_ADJ,P_TO_UV,VERT_VEL,FILTER,POLAR_UV, ADJCTL1A.200
* P_TH_ADJ MM240293.11
C*--------------------------------------------------------------------- ADJCTL1A.206
CL CALL COMDECK TO OBTAIN CONSTANTS USED. ADJCTL1A.207
ADJCTL1A.208
*CALL C_ADJCTL ADJCTL1A.209
ADJCTL1A.210
CL MAXIMUM VECTOR LENGTH ASSUMED IS P_FIELD ADJCTL1A.211
CL--------------------------------------------------------------------- ADJCTL1A.212
CL INTERNAL STRUCTURE INCLUDING SUBROUTINE CALLS: ADJCTL1A.213
CL ADJCTL1A.214
CL--------------------------------------------------------------------- ADJCTL1A.215
CL SECTION 1. INITIALISATION ADJCTL1A.216
CL--------------------------------------------------------------------- ADJCTL1A.217
C INCLUDE LOCAL CONSTANTS FROM GENERAL CONSTANTS BLOCK ADJCTL1A.218
ADJCTL1A.219
RECIP_PREF = 1./PREF ADJCTL1A.227
RECIP_PREF_TO_THE_KAPPA = RECIP_PREF**KAPPA ADJCTL1A.229
RECIP_ADJUSTMENT_STEPS = 1./ADJUSTMENT_STEPS ADJCTL1A.231
ADJCTL1A.232
*IF DEF,GLOBAL ADJCTL1A.233
CL IF GLOBAL THEN SET FILTERING INFORMATION. ADJCTL1A.234
ADJCTL1A.235
NORTHERN_FILTERED_U_ROW = NORTHERN_FILTERED_P_ROW ADJCTL1A.236
SOUTHERN_FILTERED_U_ROW = SOUTHERN_FILTERED_P_ROW - 1 ADJCTL1A.237
ADJCTL1A.238
C SET FILTER_SPACE WHICH IS ROW_LENGTH+2 TIMES THE NUMBER OF ROWS TO ADJCTL1A.239
C BE FILTERED. ADJCTL1A.240
ADJCTL1A.241
FILTER_SPACE_U = (ROW_LENGTH+2)*(NORTHERN_FILTERED_U_ROW-1+ ADJCTL1A.242
* U_FIELD/ROW_LENGTH-SOUTHERN_FILTERED_U_ROW) ADJCTL1A.243
FILTER_SPACE_P = (ROW_LENGTH+2)*(NORTHERN_FILTERED_P_ROW-1+ ADJCTL1A.244
* P_FIELD/ROW_LENGTH-SOUTHERN_FILTERED_P_ROW) ADJCTL1A.245
ADJCTL1A.246
*ELSE ADJCTL1A.247
CL IF LIMITED AREA SET U,V AT END OF ROW EQUAL TO U,V 1 GRID-LENGTH ADJCTL1A.248
CL TO THE LEFT. ADJCTL1A.249
ADJCTL1A.250
*IF DEF,MPP APB0F401.149
IF (at_right_of_LPG) THEN ! only do this at the RHS of the LPG APB0F401.150
*ENDIF APB0F401.151
DO K=1,P_LEVELS APB0F401.152
DO I=FIRST_FLD_PT-1+LAST_ROW_PT , LAST_U_FLD_PT , ROW_LENGTH APB0F401.153
! Loop over the right-hand column of the field APB0F401.154
U(I,K) = U(I-1,K) APB0F401.155
V(I,K) = V(I-1,K) APB0F401.156
ENDDO APB0F401.157
ENDDO APB0F401.158
*IF DEF,MPP APB0F401.159
ENDIF ! if this processor is at the RHS of the LPG APB0F401.160
*ENDIF APB0F401.161
*ENDIF ADJCTL1A.257
C SET U_MEAN, ETADOT_MEAN, AND V_MEAN TO ZERO ADJCTL1A.258
ADJCTL1A.259
DO 102 K = 1,P_LEVELS ADJCTL1A.260
DO 104 I = 1,U_FIELD ADJCTL1A.261
U_MEAN(I,K) = 0. ADJCTL1A.262
V_MEAN(I,K) = 0. ADJCTL1A.263
104 CONTINUE ADJCTL1A.264
DO 106 I = 1,P_FIELD ADJCTL1A.265
ETADOT_MEAN(I,K) = 0. ADJCTL1A.266
DIVERGENCE_FUNCTIONS(I,K) = 0.0 ARB2F402.40
106 CONTINUE ADJCTL1A.267
102 CONTINUE ADJCTL1A.268
ADJCTL1A.269
CL LOOP OVER NUMBER OF ADJUSTMENT STEPS. ADJCTL1A.270
ADJCTL1A.271
DO 110 ADJ_STEP_NUMBER = 1,ADJUSTMENT_STEPS ADJCTL1A.272
ADJCTL1A.273
CL ADJCTL1A.274
CL--------------------------------------------------------------------- ADJCTL1A.275
CL SECTION 2. CALL UV_ADJ TO ADJUST U AND V. ALSO RETURNS RS. ADJCTL1A.276
CL--------------------------------------------------------------------- ADJCTL1A.277
ADJCTL1A.278
CALL UV_ADJ(U,V,THETA,Q,OROG_HEIGHT,PSTAR,F1,F2, MM240293.12
* F3,SEC_U_LATITUDE,TAN_U_LATITUDE,AK,BK,DELTA_AK, ADJCTL1A.280
* DELTA_BK,LATITUDE_STEP_INVERSE,ADJUSTMENT_TIMESTEP, ADJCTL1A.281
* LONGITUDE_STEP_INVERSE,RS, ADJCTL1A.282
*CALL ARGFLDPT APB0F401.162
* U_FIELD,P_FIELD,ROW_LENGTH,P_LEVELS, APB0F401.163
* Q_LEVELS,ADJ_STEP_NUMBER,AKH,BKH,P_EXNER, ADJCTL1A.284
* ADJUSTMENT_STEPS,L_PHI_OUT,PHI_OUT,LLINTS, GSS1F304.784
* LWHITBROM) GSS1F304.785
CL ADJCTL1A.288
CL--------------------------------------------------------------------- ADJCTL1A.289
CL SECTION 3. MASS-WEIGHTING OF U AND V. ADJCTL1A.290
CL--------------------------------------------------------------------- ADJCTL1A.291
ADJCTL1A.292
! QAN fix APB0F401.164
DO I=1,P_FIELD APB0F401.165
RS_DELTAP(I)=0.0 APB0F401.166
ENDDO APB0F401.167
CL LOOP OVER P_LEVELS ADJCTL1A.293
ADJCTL1A.294
CMIC@ DO ALL SHARED(P_LEVELS, P_FIELD, U_FIELD, ROW_LENGTH, RS, APB0F401.168
CMIC@1 DELTA_AK, DELTA_BK, PSTAR, U, V) PRIVATE(RS_DELTAP_UV, AAD2F304.124
CMIC@2 RS_DELTAP, K, I) AAD2F304.125
*CALL CMICFLD APB0F401.169
DO 300 K = 1,P_LEVELS ADJCTL1A.295
ADJCTL1A.296
CL CALCULATE RS * DELTA P AT ALL POINTS ADJCTL1A.297
ADJCTL1A.298
! loop over all points, including valid halos APB0F401.170
DO 310 I= FIRST_VALID_PT , LAST_P_VALID_PT APB0F401.171
RS_DELTAP(I) = RS(I,K)*(DELTA_AK(K) + DELTA_BK(K)*PSTAR(I)) ADJCTL1A.300
310 CONTINUE ADJCTL1A.301
ADJCTL1A.302
CL INTERPOLATE RS DELTAP ONTO U GRID ADJCTL1A.303
ADJCTL1A.304
CALL P_TO_UV(RS_DELTAP,RS_DELTAP_UV,P_FIELD,U_FIELD, ADJCTL1A.305
& ROW_LENGTH,tot_P_ROWS) APB0F401.172
ADJCTL1A.307
CL CALCULATE MASS WEIGHTED U AND V COS(PHI) AT ALL POINTS. ADJCTL1A.308
ADJCTL1A.309
! loop over "local" points - not including top and bottom halos APB0F401.173
DO 320 I= FIRST_FLD_PT,LAST_U_FLD_PT APB0F401.174
U(I,K) = U(I,K)*RS_DELTAP_UV(I) ADJCTL1A.311
V(I,K) = V(I,K)*RS_DELTAP_UV(I) ADJCTL1A.312
320 CONTINUE ADJCTL1A.313
ADJCTL1A.314
CL END LOOP OVER P_LEVELS ADJCTL1A.315
ADJCTL1A.316
300 CONTINUE ADJCTL1A.317
ADJCTL1A.318
CL ADJCTL1A.319
CL--------------------------------------------------------------------- ADJCTL1A.320
CL SECTION 4. FILTER U,V AND DIVERGENCE FUNCTIONS IF GLOBAL MODEL. ADJCTL1A.321
CL--------------------------------------------------------------------- ADJCTL1A.322
ADJCTL1A.323
*IF DEF,GLOBAL ADJCTL1A.324
ADJCTL1A.325
C---------------------------------------------------------------------- ADJCTL1A.326
CL SECTION 4.1 U_FIELD ADJCTL1A.327
C---------------------------------------------------------------------- ADJCTL1A.328
ADJCTL1A.329
CL CALL FILTER FOR U ADJCTL1A.330
ADJCTL1A.331
CALL FILTER(U,U_FIELD,P_LEVELS,FILTER_SPACE_U,ROW_LENGTH, ADJCTL1A.332
*CALL ARGFLDPT APB0F402.8
* FILTER_WAVE_NUMBER_U_ROWS,TRIGS,IFAX, ADJCTL1A.333
* NORTHERN_FILTERED_U_ROW,SOUTHERN_FILTERED_U_ROW) ADJCTL1A.334
ADJCTL1A.335
C---------------------------------------------------------------------- ADJCTL1A.336
CL SECTION 4.2 V_FIELD ADJCTL1A.337
C---------------------------------------------------------------------- ADJCTL1A.338
ADJCTL1A.339
CL CALL FILTER FOR V ADJCTL1A.340
ADJCTL1A.341
CALL FILTER(V,U_FIELD,P_LEVELS,FILTER_SPACE_U,ROW_LENGTH, ADJCTL1A.342
*CALL ARGFLDPT APB0F402.9
* FILTER_WAVE_NUMBER_U_ROWS,TRIGS,IFAX, ADJCTL1A.343
* NORTHERN_FILTERED_U_ROW,SOUTHERN_FILTERED_U_ROW) ADJCTL1A.344
ADJCTL1A.345
CALL POLAR_UV(U,V,ROW_LENGTH,U_FIELD,P_LEVELS, APB2F401.198
*CALL ARGFLDPT APB2F401.199
& COS_U_LONGITUDE,SIN_U_LONGITUDE) APB2F401.200
*ENDIF ADJCTL1A.346
ADJCTL1A.347
DO K = 1,P_LEVELS ADJCTL1A.348
C MULTIPLY V BY COS(PHI). ADJCTL1A.355
ADJCTL1A.356
! loop over "local" points - not including top and bottom halos APB0F401.175
DO I= FIRST_FLD_PT,LAST_U_FLD_PT APB0F401.176
V(I,K) = V(I,K)* COS_U_LATITUDE(I) ADJCTL1A.358
ENDDO ADJCTL1A.359
ENDDO ADJCTL1A.360
ADJCTL1A.361
*IF DEF,MPP APB0F401.177
APB0F401.178
! Do halo update for U and V APB0F401.179
CALL SWAPBOUNDS(U,ROW_LENGTH,tot_P_ROWS, APB0F401.180
& EW_Halo,NS_Halo,P_LEVELS) APB0F401.181
CALL SWAPBOUNDS(V,ROW_LENGTH,tot_P_ROWS, APB0F401.182
& EW_Halo,NS_Halo,P_LEVELS) APB0F401.183
*ENDIF APB0F401.184
CL ADJCTL1A.362
CL--------------------------------------------------------------------- ADJCTL1A.363
CL SECTION 5. CALCULATE U_MEAN,V_MEAN AND ETA DOT. ADJCTL1A.364
CL--------------------------------------------------------------------- ADJCTL1A.365
ADJCTL1A.366
IF(ADJ_TIME_SMOOTHING_COEFF.NE.0.0) THEN ADJCTL1A.367
IF(ADJ_STEP_NUMBER.EQ.1) THEN ADJCTL1A.368
DO 520 K=1,P_LEVELS ADJCTL1A.369
! loop over all points, including valid halos APB0F401.185
DO I=FIRST_VALID_PT,LAST_U_VALID_PT APB0F401.186
U_SMOOTH(I,K)=ADJ_TIME_SMOOTHING_WEIGHT(ADJ_STEP_NUMBER) ADJCTL1A.371
& *U(I,K) ADJCTL1A.372
V_SMOOTH(I,K)=ADJ_TIME_SMOOTHING_WEIGHT(ADJ_STEP_NUMBER) ADJCTL1A.373
& *V(I,K) ADJCTL1A.374
END DO ADJCTL1A.375
520 CONTINUE ADJCTL1A.376
ELSE IF(ADJ_STEP_NUMBER.EQ.ADJUSTMENT_STEPS) THEN ADJCTL1A.377
DO 530 K=1,P_LEVELS ADJCTL1A.378
! loop over all points, including valid halos APB0F401.187
DO I=FIRST_VALID_PT,LAST_U_VALID_PT APB0F401.188
U(I,K) = U(I,K)+ADJ_TIME_SMOOTHING_COEFF ADJCTL1A.380
& *(ADJ_TIME_SMOOTHING_WEIGHT(ADJ_STEP_NUMBER) ADJCTL1A.381
& *U(I,K)+U_SMOOTH(I,K)) ADJCTL1A.382
V(I,K) = V(I,K)+ADJ_TIME_SMOOTHING_COEFF ADJCTL1A.383
& *(ADJ_TIME_SMOOTHING_WEIGHT(ADJ_STEP_NUMBER) ADJCTL1A.384
& *V(I,K)+V_SMOOTH(I,K)) ADJCTL1A.385
END DO ADJCTL1A.386
530 CONTINUE ADJCTL1A.387
ELSE ADJCTL1A.388
DO 540 K=1,P_LEVELS ADJCTL1A.389
! loop over all points, including valid halos APB0F401.189
DO I=FIRST_VALID_PT,LAST_U_VALID_PT APB0F401.190
U_SMOOTH(I,K)=U_SMOOTH(I,K) + ADJCTL1A.391
& ADJ_TIME_SMOOTHING_WEIGHT(ADJ_STEP_NUMBER) * ADJCTL1A.392
& U(I,K) ADJCTL1A.393
V_SMOOTH(I,K)=V_SMOOTH(I,K) + ADJCTL1A.394
& ADJ_TIME_SMOOTHING_WEIGHT(ADJ_STEP_NUMBER) * ADJCTL1A.395
& V(I,K) ADJCTL1A.396
END DO ADJCTL1A.397
540 CONTINUE ADJCTL1A.398
END IF ADJCTL1A.399
END IF ADJCTL1A.400
ADJCTL1A.401
CL CALCULATE U_MEAN AND V_MEAN AT ALL POINTS AND ALL LEVELS. ADJCTL1A.402
ADJCTL1A.403
DO 500 K = 1,P_LEVELS ADJCTL1A.404
! loop over all points, including valid halos APB0F401.191
DO 510 I = FIRST_VALID_PT,LAST_U_VALID_PT APB0F401.192
U_MEAN(I,K)= U_MEAN(I,K) + U(I,K) * RECIP_ADJUSTMENT_STEPS ADJCTL1A.406
V_MEAN(I,K)= V_MEAN(I,K) + V(I,K) * RECIP_ADJUSTMENT_STEPS ADJCTL1A.407
510 CONTINUE ADJCTL1A.408
500 CONTINUE ADJCTL1A.409
ADJCTL1A.410
CL CALL VERT_VEL TO CALCULATE ETA DOT. ADJCTL1A.411
CL BOTH ETA DOT FOR THIS ADJUSTMENT STEP AND THE AVERAGED VALUE ADJCTL1A.412
CL ARE RETURNED. ADJCTL1A.413
CL THE SUM OF THE DIVERGENCES ARE HELD AT LEVEL 1 IN THE ARRAY. ADJCTL1A.414
ADJCTL1A.415
C ETA DOT FOR THIS ADJUSTMENT STEP IS RETURNED IN DIVERGENCE FUNCTIONS. ADJCTL1A.416
ADJCTL1A.417
CALL VERT_VEL(U,V,ETADOT_MEAN,SEC_P_LATITUDE, ADJCTL1A.418
* DIVERGENCE_FUNCTIONS, ADJCTL1A.419
* U_FIELD,P_FIELD,P_LEVELS, APB0F401.193
*CALL ARGFLDPT APB0F401.194
* ROW_LENGTH,LATITUDE_STEP_INVERSE, ADJCTL1A.421
* LONGITUDE_STEP_INVERSE,ADJUSTMENT_STEPS,AKH,BKH, ADJCTL1A.422
* RS,ADJ_STEP_NUMBER,RECIP_RS_SQUARED_SURFACE, ADJCTL1A.423
* PSTAR,LLINTS,LWHITBROM) GSS1F304.786
ADJCTL1A.425
*IF DEF,MPP APB0F305.177
! Update halos for DIVERGENCE_FUNCTIONS APB0F401.195
CALL SWAPBOUNDS(DIVERGENCE_FUNCTIONS,ROW_LENGTH,tot_P_ROWS, APB0F401.196
& EW_Halo,NS_Halo,P_LEVELS) APB0F401.197
APB0F305.181
*ENDIF APB0F305.182
CL ADJCTL1A.426
CL--------------------------------------------------------------------- ADJCTL1A.427
CL SECTION 6. RECREATE U AND V FROM MASS-WEIGHTING U AND V COS(PHI). ADJCTL1A.428
CL--------------------------------------------------------------------- ADJCTL1A.429
ADJCTL1A.430
CL LOOP OVER P_LEVELS ADJCTL1A.431
ADJCTL1A.432
DO 600 K = 1,P_LEVELS ADJCTL1A.433
ADJCTL1A.434
CL CALCULATE RS* DELTA P AT ALL POINTS ADJCTL1A.435
ADJCTL1A.436
! loop over all points, including valid halos APB0F401.198
DO 610 I= FIRST_VALID_PT,LAST_P_VALID_PT APB0F401.199
RS_DELTAP(I) = RS(I,K)*(DELTA_AK(K) + DELTA_BK(K)*PSTAR(I)) ADJCTL1A.438
610 CONTINUE ADJCTL1A.439
ADJCTL1A.440
CL INTERPOLATE RS DELTAP ONTO U GRID ADJCTL1A.441
ADJCTL1A.442
CALL P_TO_UV(RS_DELTAP,RS_DELTAP_UV,P_FIELD,U_FIELD, ADJCTL1A.443
& ROW_LENGTH,tot_P_ROWS) APB0F401.200
ADJCTL1A.445
CL RECREATE U AND V FORM MASS-WEIGHTED U AND V COS(PHI) AT ALL POINTS ADJCTL1A.446
ADJCTL1A.447
! loop over "local" points - not including top and bottom halos APB0F401.201
DO 620 I= FIRST_FLD_PT,LAST_U_FLD_PT APB0F401.202
RECIP_RS_DELTAP = 1./ RS_DELTAP_UV(I) ADJCTL1A.449
U(I,K) = U(I,K) * RECIP_RS_DELTAP ADJCTL1A.450
V(I,K) = V(I,K) * RECIP_RS_DELTAP * SEC_U_LATITUDE(I) ADJCTL1A.451
620 CONTINUE ADJCTL1A.452
ADJCTL1A.453
CL END LOOP OVER P_LEVELS ADJCTL1A.454
ADJCTL1A.455
600 CONTINUE ADJCTL1A.456
ADJCTL1A.457
*IF DEF,MPP APB0F305.191
! Do boundary swap for U and V APB0F305.192
CALL SWAPBOUNDS(U,ROW_LENGTH,tot_P_ROWS, APB0F401.203
& EW_Halo,NS_Halo,P_LEVELS) APB0F401.204
CALL SWAPBOUNDS(V,ROW_LENGTH,tot_P_ROWS, APB0F401.205
& EW_Halo,NS_Halo,P_LEVELS) APB0F401.206
*ENDIF APB0F305.195
CL ADJCTL1A.458
CL--------------------------------------------------------------------- ADJCTL1A.459
CL SECTION 7. CALL P_TH_ADJ TO ADJUST P* AND THETA. ADJCTL1A.460
CL--------------------------------------------------------------------- ADJCTL1A.461
ADJCTL1A.462
CALL P_TH_ADJ(PSTAR,PSTAR_OLD,THETA,THETA_REF, ADJCTL1A.463
* DIVERGENCE_FUNCTIONS,RS,DELTA_AK,DELTA_BK, ADJCTL1A.464
* P_FIELD,P_LEVELS, APB0F401.207
*CALL ARGFLDPT APB0F401.208
* ADJ_STEP_NUMBER,ADJUSTMENT_TIMESTEP, ADJCTL1A.466
* ERROR_CODE,ERROR_MESSAGE, ADJCTL1A.467
* RECIP_RS_SQUARED_SURFACE,L_NEG_PSTAR) ADJCTL1A.468
ADJCTL1A.469
IF(ERROR_CODE.NE.0) RETURN ADJCTL1A.470
*IF DEF,MPP APB0F305.196
! Do boundary swap for PSTAR and THETA APB0F305.197
CALL SWAPBOUNDS(PSTAR,ROW_LENGTH,tot_P_ROWS, APB0F401.209
& EW_Halo,NS_Halo,1) APB0F401.210
! CALL SET_SIDES(PSTAR,P_FIELD,ROW_LENGTH,1,fld_type_p) APB0F401.211
! CALL SWAPBOUNDS(THETA,ROW_LENGTH,lasize(2), APB0F401.212
! & EW_Halo,NS_Halo,P_LEVELS) APB0F401.213
*ENDIF APB0F305.201
CL ADJCTL1A.471
CL--------------------------------------------------------------------- ADJCTL1A.472
CL SECTION 8. CALCULATE P_EXNER FOR PRESSURE AT NEW TIME-LEVEL. ADJCTL1A.473
CL CALCULATION PERFORMED AT ALL HALF-LEVELS. ADJCTL1A.474
CL--------------------------------------------------------------------- ADJCTL1A.475
C GSS4F402.22
DO 800 K=1,P_LEVELS+1 ADJCTL1A.479
ADJCTL1A.480
C CALCULATE EXNER AT LEVEL K - 1/2 ADJCTL1A.481
ADJCTL1A.482
IF(BKH(K).EQ.0.) THEN ADJCTL1A.483
C IF A CONSTANT PRESSURE SURFACE SET EXNER TO HELD CONSTANT VALUE. ADJCTL1A.484
DO 810 I= 1,P_FIELD ADJCTL1A.485
P_EXNER(I,K) = AKH_TO_THE_KAPPA(K) ADJCTL1A.486
810 CONTINUE ADJCTL1A.487
ADJCTL1A.488
ELSE IF (K.GT.1.AND.AKH(K).EQ.0.) THEN MM240293.14
C IF A SIGMA LEVEL THEN THE LEVEL BELOW WAS A SIGMA LEVEL AND ADJCTL1A.490
C EXNER CAN BE CALCULATED BY RESCALING THE VALUE AT THE LOWER LEVEL. ADJCTL1A.491
ADJCTL1A.492
SCALAR = BKH_TO_THE_KAPPA(K)/BKH_TO_THE_KAPPA(K-1) ADJCTL1A.493
! loop over all points, including valid halos APB0F401.214
DO 820 I=FIRST_VALID_PT,LAST_P_VALID_PT APB0F401.215
P_EXNER(I,K) = P_EXNER(I,K-1)* SCALAR ADJCTL1A.495
820 CONTINUE ADJCTL1A.496
ELSE ADJCTL1A.497
C CALCULATE EXNER AS ((A+B*PSTAR)/100000)**(R/CP) ADJCTL1A.498
ADJCTL1A.499
! loop over all points, including valid halos APB0F401.216
GSS4F402.23
DO I=FIRST_VALID_PT,LAST_P_VALID_PT GSS4F402.24
EXNER_wk(I-FIRST_VALID_PT+1)=AKH(K)+BKH(K)*PSTAR(I) GSS4F402.25
END DO GSS4F402.26
*IF DEF,VECTLIB PXVECTLB.1
n_inputs=LAST_P_VALID_PT-FIRST_VALID_PT+1 GSS4F402.31
call powr_v(n_inputs,EXNER_wk,KAPPA,EXNER_wk) GSS1F403.1048
*ELSE GSS4F402.33
DO I=1,LAST_P_VALID_PT-FIRST_VALID_PT+1 GSS4F402.34
*IF -DEF,FUJITSU GRB1F405.36
EXNER_wk(I)=EXNER_wk(I)**KAPPA GSS4F402.35
*ELSE GRB1F405.37
EXNER_wk(I)= exp(KAPPA*log(EXNER_wk(I))) GRB1F405.38
*ENDIF GRB1F405.39
END DO GSS4F402.36
*ENDIF GSS4F402.37
DO 830 I=FIRST_VALID_PT,LAST_P_VALID_PT APB0F401.217
P_EXNER(I,K) = EXNER_wk(I-FIRST_VALID_PT+1) GSS4F402.38
& * RECIP_PREF_TO_THE_KAPPA GSS4F402.39
830 CONTINUE ADJCTL1A.503
END IF ADJCTL1A.504
ADJCTL1A.505
800 CONTINUE ADJCTL1A.506
ADJCTL1A.507
ADJCTL1A.540
CL END OF LOOP OVER ADJUSTMENT STEPS ADJCTL1A.541
ADJCTL1A.542
110 CONTINUE ADJCTL1A.543
*IF DEF,MPP APB0F401.223
! Update halos for ETADOT_MEAN APB0F401.224
CALL SWAPBOUNDS(ETADOT_MEAN,ROW_LENGTH,tot_P_ROWS, APB0F401.225
& EW_Halo,NS_Halo,P_LEVELS) APB0F401.226
*ENDIF APB0F401.227
ADJCTL1A.544
CL END OF ROUTINE ADJ_CTL ADJCTL1A.545
ADJCTL1A.546
RETURN ADJCTL1A.547
END ADJCTL1A.548
ADJCTL1A.549
*ENDIF ADJCTL1A.550
*ENDIF AJC0F405.258