SUBROUTINE G_WAVE 2,24GWAVE3A.5
1 (PSTAR,PEXNER,THETA,Q,U,V,P_FIELD,U_FIELD, GWAVE3A.6
2 ROWS_P,ROW_LENGTH,START_LEVEL,LEVELS,Q_LEVELS, GWAVE3A.7
*CALL ARGFLDPT 
APBEF401.40
3 AK,BK,AKH,BKH,DELTA_AK,DELTA_BK,SD_OROG_LAND, GWAVE3A.8
4 OROG_GRAD_XX_LAND,OROG_GRAD_XY_LAND,OROG_GRAD_YY_LAND, GWAVE3A.9
5 LAND_INDEX,LAND_POINTS,TIMESTEP,KAY,KAY_LEE, ASW1F403.28
6 STRESS_UD,LEN_STRESS_UD,STRESS_UD_ON,U_LIST1,POINTS_STRESS_UD, GWAVE3A.11
7 STRESS_VD,LEN_STRESS_VD,STRESS_VD_ON,V_LIST1,POINTS_STRESS_VD, GWAVE3A.12
8 DU_DT_SATN,LEN_DU_DT_SATN,DU_DT_SATN_ON, GWAVE3A.13
9 U_LIST2,POINTS_DU_DT_SATN, GWAVE3A.14
& DV_DT_SATN,LEN_DV_DT_SATN,DV_DT_SATN_ON, GWAVE3A.15
& V_LIST2,POINTS_DV_DT_SATN, GWAVE3A.16
& DU_DT_JUMP,LEN_DU_DT_JUMP,DU_DT_JUMP_ON, GWAVE3A.17
& U_LIST3,POINTS_DU_DT_JUMP, GWAVE3A.18
& DV_DT_JUMP,LEN_DV_DT_JUMP,DV_DT_JUMP_ON, GWAVE3A.19
& V_LIST3,POINTS_DV_DT_JUMP, GWAVE3A.20
& DU_DT_LEE,LEN_DU_DT_LEE,DU_DT_LEE_ON,U_LIST4,POINTS_DU_DT_LEE, GWAVE3A.21
& DV_DT_LEE,LEN_DV_DT_LEE,DV_DT_LEE_ON,V_LIST4,POINTS_DV_DT_LEE, GWAVE3A.22
& TRANS_D,LEN_TRANS_D,TRANS_D_ON,POINTS_TRANS_D,IRET) GWAVE3A.23
GWAVE3A.24
IMPLICIT NONE GWAVE3A.25
! GWAVE3A.26
! Description: GWAVE3A.27
! 1) INTERPOLATE WINDS TO P/THETA POINTS GWAVE3A.28
! 2) GATHER DATA FOR LAND POINTS ONLY GWAVE3A.29
! 3) CALL ANISOTOPIC SURFACE STRESS ROUTINE GWAVE3A.30
! 4) CALL VERTICAL STRESS PROFILE ROUTINE TO CALCULATE DRAG AT GWAVE3A.31
! EACH LEVEL GWAVE3A.32
! 5) INTERPOLATE ACCELERATION TO WIND POINTS AND UPDATE WINDS GWAVE3A.33
! GWAVE3A.34
! Current Code Owner: S.Webster ASW1F403.29
! GWAVE3A.36
! History: GWAVE3A.37
! Version Date Comment GWAVE3A.38
! ------- ---- ------- GWAVE3A.39
! 3.4 18/10/94 Original code. J.R.Mitchell. GWAVE3A.40
! 4.3 7/03/97 KAY_LEE passed in from namelist. S.Webster ASW1F403.30
! 4.4 19/09/97 Remove *IF -DEF,CRAY compile options. S.Webster ASW1F404.6
! 4.5 13/03/97 Correct MPP GWD diagnostic bug. S. Webster ASW1F405.19
CLL 4.5 Jul. 98 Kill the IBM specific lines. AJC1F405.190
CLL Replace IBM with SCMA (JCThil) AJC1F405.191
! GWAVE3A.41
! Code Description: GWAVE3A.42
! Language: FORTRAN 77 + common extensions. GWAVE3A.43
! This code is written to UMDP3 v6 programming standards. GWAVE3A.44
! System component covered: GWAVE3A.45
! System Task: Part of P22 GWAVE3A.46
! SUITABLE FOR SINGLE COLUMN USE, WITH CALLS TO: UV_TO_P REMOVED GWAVE3A.47
! P_TO_UV REMOVED GWAVE3A.48
! (SCMA on) AJC1F405.192
! SUITABLE FOR ROTATED GRIDS GWAVE3A.49
! GWAVE3A.50
! Global variables (*CALLed COMDECKs etc...): GWAVE3A.51
GWAVE3A.52
! Subroutine arguments GWAVE3A.53
GWAVE3A.54
INTEGER GWAVE3A.55
* P_FIELD !IN 1ST DIMENSION OF FIELD OF PSTAR GWAVE3A.56
*, U_FIELD !IN 1ST DIMENSION OF FIELD OF U,V GWAVE3A.57
*, ROWS_P !IN NUMBER OF ROWS of P grid GWAVE3A.58
*, ROW_LENGTH !IN NUMBER OF POINTS PER ROW GWAVE3A.59
*, START_LEVEL !IN START OF WAVE-BREAKING TEST GWAVE3A.60
*, LEVELS !IN NUMBER OF MODEL LEVELS GWAVE3A.61
*, Q_LEVELS !IN NUMBER OF WET LEVELS GWAVE3A.62
*, LAND_POINTS !IN NUMBER OF LAND POINTS GWAVE3A.63
*, LAND_INDEX((ROWS_P)*ROW_LENGTH) ! INDEX FOR LAND POINTS GWAVE3A.64
*, IRET ! RETURN CODE : IRET=0 NORMAL EXIT GWAVE3A.65
* ! RETURN CODE : IRET=1 ????? GWAVE3A.66
*, LEN_STRESS_UD !IN ) Dimension of diagnostic arrays GWAVE3A.67
*, LEN_STRESS_VD !IN ) for GW stress - u and v GWAVE3A.68
*, POINTS_STRESS_UD !IN ) No of land points in diagnostic GWAVE3A.69
*, POINTS_STRESS_VD !IN ) arrays for GW stress - u and v GWAVE3A.70
*, LEN_DU_DT_SATN !IN ) Dimension of diagnostic arrays GWAVE3A.71
*, LEN_DV_DT_SATN !IN ) for GW satn - du and dv GWAVE3A.72
*, POINTS_DU_DT_SATN !IN ) No of land points in diagnostic GWAVE3A.73
*, POINTS_DV_DT_SATN !IN ) arrays for GW satn - du and dv GWAVE3A.74
*, LEN_DU_DT_JUMP !IN ) Dimension of diagnostic arrays GWAVE3A.75
*, LEN_DV_DT_JUMP !IN ) for GW satn - du and dv GWAVE3A.76
*, POINTS_DU_DT_JUMP !IN ) No of land points in diagnostic GWAVE3A.77
*, POINTS_DV_DT_JUMP !IN ) arrays for GW satn - du and dv GWAVE3A.78
*, LEN_DU_DT_LEE !IN ) Dimension of diagnostic arrays GWAVE3A.79
*, LEN_DV_DT_LEE !IN ) for GW lee - du and dv GWAVE3A.80
*, POINTS_DU_DT_LEE !IN ) No of land points in diagnostic GWAVE3A.81
*, POINTS_DV_DT_LEE !IN ) arrays for GW lee - du and dv GWAVE3A.82
*, LEN_TRANS_D !IN Dimension of diag for trans. coeff. GWAVE3A.83
*, POINTS_TRANS_D !IN No. of land points for trans. coeff. GWAVE3A.84
C GWAVE3A.85
C GWAVE3A.86
! All TYPFLDPT variables are Intent IN APBEF401.41
*CALL TYPFLDPT APBEF401.42
GWAVE3A.87
REAL GWAVE3A.88
* PSTAR(P_FIELD) !IN PRIMARY MODEL ARRAY FOR PSTAR FIELD GWAVE3A.89
*,PEXNER(P_FIELD,LEVELS+1) !IN ARRAY FOR EXNER PRESSURE FIELD GWAVE3A.90
*,THETA(P_FIELD,LEVELS) !IN PRIMARY MODEL ARRAY FOR THETA FIELD GWAVE3A.91
*,Q(P_FIELD,Q_LEVELS) !IN SPECIFIC HUMIDITY AT FULL LEVELS GWAVE3A.92
*,U(U_FIELD,LEVELS) !INOUT PRIMARY MODEL ARRAY FOR U FIELD GWAVE3A.93
*,V(U_FIELD,LEVELS) !INOUT PRIMARY MODEL ARRAY FOR V FIELD GWAVE3A.94
C AK,BK DEFINE HYBRID VERTICAL COORDINATES P=A+BP*, GWAVE3A.95
C DELTA_AK,DELTA_BK DEFINE LAYER PRESSURE THICKNESS PD=AD+BDP*, GWAVE3A.96
GWAVE3A.97
REAL GWAVE3A.98
* DELTA_AK(LEVELS) !IN LAYER THICKNESS GWAVE3A.99
*,DELTA_BK(LEVELS) !IN LAYER THICKNESS GWAVE3A.100
*,AK (LEVELS) !IN VALUE AT LAYER CENTRE GWAVE3A.101
*,BK (LEVELS) !IN VALUE AT LAYER CENTRE GWAVE3A.102
*,AKH(LEVELS+1) !IN VALUE AT LAYER BOUNDARY GWAVE3A.103
*,BKH(LEVELS+1) !IN VALUE AT LAYER BOUNDARY GWAVE3A.104
*,SD_OROG_LAND(LAND_POINTS) !IN STANDARD DEVIATION OF OROGRAPHY GWAVE3A.105
*,OROG_GRAD_XX_LAND(LAND_POINTS) GWAVE3A.106
* !IN DH/DX SQUARED GRADIENT OROGRAPHY GWAVE3A.107
*,OROG_GRAD_XY_LAND(LAND_POINTS) GWAVE3A.108
* !IN (DH/DX)(DH/DY) GRADIENT OROGRAPHY GWAVE3A.109
*,OROG_GRAD_YY_LAND(LAND_POINTS) GWAVE3A.110
* !IN DH/DY SQUARED GRADIENT OROGRAPHY GWAVE3A.111
*,TIMESTEP !IN TIMESTEP GWAVE3A.112
*,KAY !IN surface stress constant ( m-1) GWAVE3A.113
*,KAY_LEE !IN TRAPPED LEE WAVE CONSTANT ASW1F403.31
GWAVE3A.114
*,STRESS_UD(LEN_STRESS_UD,*) !U STRESS DIAGNOSTIC GWAVE3A.115
*,STRESS_VD(LEN_STRESS_VD,*) !V STRESS DIAGNOSTIC GWAVE3A.116
*,DU_DT_SATN(LEN_DU_DT_SATN,*) !U ACCELN DIAGNOSTIC (SATURATION) GWAVE3A.117
*,DV_DT_SATN(LEN_DV_DT_SATN,*) !V ACCELN DIAGNOSTIC (SATURATION) GWAVE3A.118
*,DU_DT_JUMP(LEN_DU_DT_JUMP,*) !U ACCELN DIAG (HYDRAULIC JUMP) GWAVE3A.119
*,DV_DT_JUMP(LEN_DV_DT_JUMP,*) !V ACCELN DIAG (HYDRAULIC JUMP) GWAVE3A.120
*,DU_DT_LEE(LEN_DU_DT_LEE,*) !U ACCELN DIAG (TRAPPED LEE WAVE) GWAVE3A.121
*,DV_DT_LEE(LEN_DV_DT_LEE,*) !V ACCELN DIAG (TRAPPED LEE WAVE) GWAVE3A.122
*,TRANS_D(LEN_TRANS_D) !TRANSMITTION COEFF DIAGN GWAVE3A.123
GWAVE3A.124
C WARNING: Storage will only be assigned by the calling routine for GWAVE3A.125
C for the number of levels required. GWAVE3A.126
GWAVE3A.127
LOGICAL GWAVE3A.128
* STRESS_UD_ON !U stress diagnostic switch GWAVE3A.129
*,STRESS_VD_ON !V stress diagnostic switch GWAVE3A.130
*,U_LIST1(LEVELS+1) ! Lists of levels for which stresses GWAVE3A.131
*,V_LIST1(LEVELS+1) ! required. GWAVE3A.132
*,DU_DT_SATN_ON !U accel (saturation) diagnostic switch GWAVE3A.133
*,DV_DT_SATN_ON !V accel (saturation) diagnostic switch GWAVE3A.134
*,U_LIST2(LEVELS) ! Lists of levels for which accelerations GWAVE3A.135
*,V_LIST2(LEVELS) ! required. GWAVE3A.136
*,DU_DT_JUMP_ON !U accel (hydr jump) diagnostic switch GWAVE3A.137
*,DV_DT_JUMP_ON !V accel (hydr jump) diagnostic switch GWAVE3A.138
*,U_LIST3(LEVELS) ! Lists of levels for which accelerations GWAVE3A.139
*,V_LIST3(LEVELS) ! required. GWAVE3A.140
*,DU_DT_LEE_ON !U accel (lee wave) diagnostic switch GWAVE3A.141
*,DV_DT_LEE_ON !V accel (lee wave) diagnostic switch GWAVE3A.142
*,U_LIST4(LEVELS) ! Lists of levels for which accelerations GWAVE3A.143
*,V_LIST4(LEVELS) ! required. GWAVE3A.144
*,TRANS_D_ON !Transmittion coefficient diag switch GWAVE3A.145
GWAVE3A.146
! Local dynamic arrays: GWAVE3A.147
GWAVE3A.148
C--- WORKSPACE USAGE:------------------------------------------------- GWAVE3A.149
C DEFINE LOCAL WORKSPACE ARRAYS: GWAVE3A.150
C 8 ARRAYS AT FULL FIELD LENGTH REQUIRED GWAVE3A.151
C 6*LEVELS+9 REAL ARRAYS OF LAND_POINTS LENGTH REQUIRED GWAVE3A.152
C 8*LEVELS REAL ARRAYS OF LAND_POINTS LENGTH REQUIRED FOR DIAGNOSTICS GWAVE3A.153
C---------------------------------------------------------------------- GWAVE3A.154
GWAVE3A.155
INTEGER GWAVE3A.171
* K_LIFT(LAND_POINTS) ! MODEL LEVEL OF BLOCKED LAYER GWAVE3A.172
GWAVE3A.173
REAL GWAVE3A.174
* WORK(P_FIELD,4) ! GENERAL PURPOSE WORK GWAVE3A.175
*,UP_LAND(LAND_POINTS,LEVELS) ! INTERPOLATED U COMPONENT ON PGRID GWAVE3A.176
*,VP_LAND(LAND_POINTS,LEVELS) ! INTERPOLATED U COMPONENT ON PGRID GWAVE3A.177
*,THETA_LAND(LAND_POINTS,LEVELS)! THETA LAND POINTS GWAVE3A.178
*,Q_LAND(LAND_POINTS,Q_LEVELS) ! Q LAND POINTS GWAVE3A.179
*,S_X_STRESS(LAND_POINTS) ! 'SURFACE' X_STRESS LAND POINTS GWAVE3A.180
*,S_Y_STRESS(LAND_POINTS) ! 'SURFACE' Y_STRESS LAND POINTS GWAVE3A.181
*,S_X_OROG(LAND_POINTS) ! 'SURFACE' X_OROG LAND POINTS GWAVE3A.182
*,S_Y_OROG(LAND_POINTS) ! 'SURFACE' Y_OROG LAND POINTS GWAVE3A.183
*,PSTAR_LAND(LAND_POINTS) ! PSTAR LAND POINTS GWAVE3A.184
*,PEXNER_LAND(LAND_POINTS,LEVELS+1) ! PEXNER LAND POINTS GWAVE3A.185
*,DU_DT(LAND_POINTS,LEVELS) ! U-ACCELERATION GWAVE3A.186
*,DV_DT(LAND_POINTS,LEVELS) ! V-ACCELERATION GWAVE3A.187
*,TEST(LAND_POINTS) ! TEST FOR LEE/H_JUMP GWAVE3A.188
*,U_S(LAND_POINTS) ! U-WINDS OVER 'SURFACE' GWAVE3A.189
*,V_S(LAND_POINTS) ! V-WINDS OVER 'SURFACE' GWAVE3A.190
*,RHO_S(LAND_POINTS) ! DENSITY OVER 'SURFACE' GWAVE3A.191
GWAVE3A.192
REAL GWAVE3A.193
* STRESS_UD_LAND(POINTS_STRESS_UD,LEVELS+1) !U STRESS DIAGNOSTIC GWAVE3A.194
*,STRESS_VD_LAND(POINTS_STRESS_VD,LEVELS+1) !V STRESS DIAGNOSTIC GWAVE3A.195
*,DU_DT_SATN_LAND(POINTS_DU_DT_SATN,LEVELS) !U ACCELN DIAGNOSTIC GWAVE3A.196
*,DV_DT_SATN_LAND(POINTS_DV_DT_SATN,LEVELS) !V ACCELN DIAGNOSTIC GWAVE3A.197
*,DU_DT_JUMP_LAND(POINTS_DU_DT_JUMP,LEVELS) !U ACCELN DIAGNOSTIC GWAVE3A.198
*,DV_DT_JUMP_LAND(POINTS_DV_DT_JUMP,LEVELS) !V ACCELN DIAGNOSTIC GWAVE3A.199
*,DU_DT_LEE_LAND(POINTS_DU_DT_LEE,LEVELS) !U ACCELN DIAGNOSTIC GWAVE3A.200
*,DV_DT_LEE_LAND(POINTS_DV_DT_LEE,LEVELS) !V ACCELN DIAGNOSTIC GWAVE3A.201
*,TRANS_D_LAND(POINTS_TRANS_D) !TRANSMITTION COEFF GWAVE3A.202
GWAVE3A.205
! Function & Subroutine calls: GWAVE3A.206
EXTERNAL GW_SURF,GW_VERT AJC1F405.193
*IF -DEF,SCMA AJC1F405.194
& ,P_TO_UV,UV_TO_P AJC1F405.195
*ENDIF AJC1F405.196
GWAVE3A.208
C*------------------------------------------------------------------ GWAVE3A.209
CL MAXIMUM VECTOR LENGTH ASSUMED IS (ROWS_P+1) * ROWLENGTH GWAVE3A.210
C---------------------------------------------------------------------- GWAVE3A.211
! Local parameters: GWAVE3A.212
GWAVE3A.213
! Local scalars: GWAVE3A.214
GWAVE3A.215
INTEGER GWAVE3A.216
* P_POINTS ! NUMBER OF P POINTS NEEDED GWAVE3A.217
*, U_POINTS_1 ! No. U points used to interpolate to P-grid GWAVE3A.218
*, U_POINTS ! NUMBER OF U POINTS UPDATED GWAVE3A.219
*, START_U ! Start position of U points updated GWAVE3A.220
*, START_U1 ! Start position of diagnostics updated ASW1F405.20
C GWAVE3A.221
INTEGER I,IW,K, ! LOOP COUNTERS IN ROUTINE GWAVE3A.222
* KOUT_U,KOUT_V GWAVE3A.223
C GWAVE3A.224
GWAVE3A.225
C GWAVE3A.226
GWAVE3A.227
C------------------------------------------------------------------- GWAVE3A.228
CL 1. INITIALISATION GWAVE3A.229
CL 1.1 SET UP DIMENSIONS GWAVE3A.230
C------------------------------------------------------------------ GWAVE3A.231
GWAVE3A.232
U_POINTS_1 = (ROWS_P+1)*ROW_LENGTH GWAVE3A.233
U_POINTS = (ROWS_P-1)*ROW_LENGTH GWAVE3A.234
P_POINTS = ROWS_P*ROW_LENGTH GWAVE3A.235
START_U = ROW_LENGTH GWAVE3A.236
C ASW1F405.21
C Three separate cases for START_U1. These arise because of different ASW1F405.22
C row offsets in the call to uv_to_p (GWAVE3A.253,256) ASW1F405.23
C ASW1F405.24
*IF DEF,MPP ASW1F405.25
IF ( at_top_of_lpg ) THEN ASW1F405.26
START_U1 = 2*ROW_LENGTH ASW1F405.27
ELSE ASW1F405.28
START_U1 = 0 ASW1F405.29
ENDIF ASW1F405.30
*ELSE ASW1F405.31
START_U1 = ROW_LENGTH ASW1F405.32
*ENDIF ASW1F405.33
GWAVE3A.237
C------------------------------------------------------------------ GWAVE3A.238
CL 1.2 INTERPOLATE WINDS TO P/THETA-GRID GWAVE3A.239
C------------------------------------------------------------------ GWAVE3A.240
DO K=1,LEVELS GWAVE3A.241
GWAVE3A.242
*IF DEF,SCMA AJC1F405.197
DO I=1,LAND_POINTS AJC1F405.198
UP_LAND(I,K) =U(LAND_INDEX(I),K) AJC1F405.199
VP_LAND(I,K) =V(LAND_INDEX(I),K) AJC1F405.200
ENDDO AJC1F405.201
ENDDO AJC1F405.202
*ELSE GWAVE3A.250
GWAVE3A.251
GWAVE3A.252
CALL UV_TO_P(U(1,K),WORK(1,1),U_POINTS_1,P_POINTS, GWAVE3A.253
* ROW_LENGTH,ROWS_P+1) GWAVE3A.254
CALL UV_TO_P(V(1,K),WORK(1,2),U_POINTS_1,P_POINTS, GWAVE3A.255
* ROW_LENGTH,ROWS_P+1) GWAVE3A.256
*IF DEF,MPP APBEF401.43
! Correct halos of interpolated U/V APBEF401.44
! Correct halos of interpolated U/V APBEF401.45
! CALL SWAPBOUNDS(WORK(1,1),LOCAL_ROW_LENGTH,ROWS_P, APBEF401.46
! & EW_Halo,NS_Halo,1) ! U field APBEF401.47
! CALL SWAPBOUNDS(WORK(1,2),LOCAL_ROW_LENGTH,ROWS_P, APBEF401.48
! & EW_Halo,NS_Halo,1) ! V field APBEF401.49
*ENDIF APBEF401.50
GWAVE3A.257
C------------------------------------------------------------------ GWAVE3A.258
CL 1.3 GATHER WINDS AT LAND POINTS GWAVE3A.259
C------------------------------------------------------------------ GWAVE3A.260
GWAVE3A.261
DO I=1,LAND_POINTS GWAVE3A.262
UP_LAND(I,K) =WORK(LAND_INDEX(I),1) GWAVE3A.263
VP_LAND(I,K) =WORK(LAND_INDEX(I),2) GWAVE3A.264
END DO GWAVE3A.265
END DO GWAVE3A.266
GWAVE3A.267
*ENDIF GWAVE3A.268
GWAVE3A.269
C------------------------------------------------------------------ GWAVE3A.270
CL 1.4 GATHER PSTAR,PEXNER,THETA,Q,SD_OROG?? AT LAND POINTS GWAVE3A.271
C------------------------------------------------------------------ GWAVE3A.272
GWAVE3A.273
DO I=1,LAND_POINTS GWAVE3A.274
PSTAR_LAND(I) = PSTAR(LAND_INDEX(I)) GWAVE3A.275
END DO GWAVE3A.276
GWAVE3A.277
CL *** Following loop labelled to workaround fmp mistranslation GWAVE3A.278
GWAVE3A.279
CFPP$ SELECT(CONCUR) GWAVE3A.280
DO 140 K=1,LEVELS GWAVE3A.281
DO I=1,LAND_POINTS GWAVE3A.282
PEXNER_LAND(I,K) = PEXNER(LAND_INDEX(I),K) GWAVE3A.283
THETA_LAND(I,K) = THETA(LAND_INDEX(I),K) GWAVE3A.284
END DO GWAVE3A.285
140 CONTINUE GWAVE3A.286
GWAVE3A.287
DO 145 K=1,Q_LEVELS GWAVE3A.288
DO I=1,LAND_POINTS GWAVE3A.289
Q_LAND(I,K) = Q(LAND_INDEX(I),K) GWAVE3A.290
END DO GWAVE3A.291
145 CONTINUE GWAVE3A.292
GWAVE3A.293
DO I=1,LAND_POINTS GWAVE3A.294
PEXNER_LAND(I,LEVELS+1) =PEXNER(LAND_INDEX(I),LEVELS+1) GWAVE3A.295
END DO GWAVE3A.296
GWAVE3A.297
C------------------------------------------------------------------ GWAVE3A.298
CL 2. CALCULATE ANISOTROPIC 'SURFACE' STRESS,CALL GW_SURF GWAVE3A.299
C------------------------------------------------------------------ GWAVE3A.300
GWAVE3A.301
CALL GW_SURF(PSTAR_LAND,PEXNER_LAND,THETA_LAND,UP_LAND,VP_LAND, GWAVE3A.302
* SD_OROG_LAND,OROG_GRAD_XX_LAND,OROG_GRAD_XY_LAND, GWAVE3A.303
* OROG_GRAD_YY_LAND,S_X_STRESS,S_Y_STRESS,S_X_OROG, GWAVE3A.304
* S_Y_OROG,LEVELS,LAND_POINTS,AK,BK,AKH,BKH,KAY,TEST, GWAVE3A.305
* K_LIFT,U_S,V_S,RHO_S) GWAVE3A.306
GWAVE3A.307
C------------------------------------------------------------------ GWAVE3A.308
CL 3. CALCULATE STRESS PROFILE AND ACCELERATIONS, GWAVE3A.309
CL CALL GW_VERT GWAVE3A.310
C------------------------------------------------------------------ GWAVE3A.311
GWAVE3A.312
CALL GW_VERT(PSTAR_LAND,PEXNER_LAND,THETA_LAND,Q_LAND,UP_LAND, GWAVE3A.313
1 VP_LAND,S_X_STRESS,S_Y_STRESS,START_LEVEL,LEVELS,Q_LEVELS, GWAVE3A.314
2 LAND_POINTS,AKH,BKH,DELTA_AK,DELTA_BK,KAY,KAY_LEE,SD_OROG_LAND, ASW1F403.32
3 S_X_OROG,S_Y_OROG,OROG_GRAD_XX_LAND,OROG_GRAD_XY_LAND, GWAVE3A.316
4 OROG_GRAD_YY_LAND,TEST,DU_DT,DV_DT,K_LIFT,U_S,V_S,RHO_S, GWAVE3A.317
5 STRESS_UD_LAND ,POINTS_STRESS_UD ,STRESS_UD_ON, GWAVE3A.318
6 STRESS_VD_LAND ,POINTS_STRESS_VD ,STRESS_VD_ON, GWAVE3A.319
7 DU_DT_SATN_LAND,POINTS_DU_DT_SATN,DU_DT_SATN_ON, GWAVE3A.320
8 DV_DT_SATN_LAND,POINTS_DV_DT_SATN,DV_DT_SATN_ON, GWAVE3A.321
9 DU_DT_JUMP_LAND,POINTS_DU_DT_JUMP,DU_DT_JUMP_ON, GWAVE3A.322
& DV_DT_JUMP_LAND,POINTS_DV_DT_JUMP,DV_DT_JUMP_ON, GWAVE3A.323
& DU_DT_LEE_LAND ,POINTS_DU_DT_LEE ,DU_DT_LEE_ON, GWAVE3A.324
& DV_DT_LEE_LAND ,POINTS_DV_DT_LEE ,DV_DT_LEE_ON, GWAVE3A.325
& TRANS_D_LAND ,POINTS_TRANS_D ,TRANS_D_ON ) GWAVE3A.326
GWAVE3A.327
C------------------------------------------------------------------ GWAVE3A.328
CL 4. SCATTER ACCELERATIONS TO FULL AREA, INTERPOLATE TO UV-GRID GWAVE3A.329
CL AND UPDATE WINDS GWAVE3A.330
C------------------------------------------------------------------ GWAVE3A.331
GWAVE3A.332
DO I=1,P_FIELD GWAVE3A.333
DO IW=1,4 GWAVE3A.334
WORK(I,IW) = 0.0 GWAVE3A.335
END DO GWAVE3A.336
END DO GWAVE3A.337
GWAVE3A.338
DO K=1,LEVELS GWAVE3A.339
GWAVE3A.340
*IF -DEF,SCMA AJC1F405.203
CDIR$ IVDEP GWAVE3A.341
! Fujitsu vectorization directive GRB0F405.323
!OCL NOVREC GRB0F405.324
DO I=1,LAND_POINTS GWAVE3A.342
WORK(LAND_INDEX(I),1)= DU_DT(I,K) GWAVE3A.343
WORK(LAND_INDEX(I),2)= DV_DT(I,K) GWAVE3A.344
END DO GWAVE3A.345
GWAVE3A.346
CALL P_TO_UV(WORK(1,1),WORK(1,3),P_POINTS,U_POINTS, GWAVE3A.347
* ROW_LENGTH,ROWS_P) GWAVE3A.348
CALL P_TO_UV(WORK(1,2),WORK(1,4),P_POINTS,U_POINTS, GWAVE3A.349
* ROW_LENGTH,ROWS_P) GWAVE3A.350
GWAVE3A.351
DO I=1,U_POINTS GWAVE3A.352
U(START_U+I,K) = U(START_U+I,K) + TIMESTEP*WORK(I,3) GWAVE3A.353
V(START_U+I,K) = V(START_U+I,K) + TIMESTEP*WORK(I,4) GWAVE3A.354
END DO GWAVE3A.355
GWAVE3A.356
*ELSE AJC1F405.204
DO I=1,U_POINTS AJC1F405.205
U(START_U+I,K) = U(START_U+I,K) + TIMESTEP*DU_DT(I,K) AJC1F405.206
V(START_U+I,K) = V(START_U+I,K) + TIMESTEP*DV_DT(I,K) AJC1F405.207
END DO AJC1F405.208
*ENDIF AJC1F405.209
END DO GWAVE3A.357
GWAVE3A.358
IF (STRESS_UD_ON .OR. STRESS_VD_ON) THEN GWAVE3A.359
GWAVE3A.360
KOUT_U=0 GWAVE3A.361
KOUT_V=0 GWAVE3A.362
DO K=START_LEVEL,LEVELS+1 GWAVE3A.363
GWAVE3A.364
IF(STRESS_UD_ON ) THEN GWAVE3A.365
IF(U_LIST1(K)) THEN GWAVE3A.366
KOUT_U=KOUT_U+1 GWAVE3A.367
! Fujitsu vectorization directive GRB0F405.325
!OCL NOVREC GRB0F405.326
CDIR$ IVDEP GWAVE3A.368
*IF -DEF,SCMA AJC1F405.210
DO I=1,LAND_POINTS GWAVE3A.369
WORK(LAND_INDEX(I),1)=STRESS_UD_LAND(I,K) GWAVE3A.370
END DO GWAVE3A.371
CALL P_TO_UV(WORK(1,1),STRESS_UD(START_U1+1,KOUT_U), ASW1F405.34
* P_POINTS,U_POINTS,ROW_LENGTH,ROWS_P) GWAVE3A.373
*ELSE AJC1F405.211
DO I=1,LAND_POINTS AJC1F405.212
STRESS_UD(START_U+LAND_INDEX(I),KOUT_U)= AJC1F405.213
& STRESS_UD_LAND(I,K) AJC1F405.214
END DO AJC1F405.215
*ENDIF AJC1F405.216
ENDIF GWAVE3A.374
ENDIF GWAVE3A.375
GWAVE3A.376
IF(STRESS_VD_ON ) THEN GWAVE3A.377
IF(V_LIST1(K)) THEN GWAVE3A.378
KOUT_V=KOUT_V+1 GWAVE3A.379
! Fujitsu vectorization directive GRB0F405.327
!OCL NOVREC GRB0F405.328
CDIR$ IVDEP GWAVE3A.380
*IF -DEF,SCMA AJC1F405.217
DO I=1,LAND_POINTS GWAVE3A.381
WORK(LAND_INDEX(I),2)=STRESS_VD_LAND(I,K) GWAVE3A.382
END DO GWAVE3A.383
CALL P_TO_UV(WORK(1,2),STRESS_VD(START_U1+1,KOUT_V), ASW1F405.35
* P_POINTS,U_POINTS,ROW_LENGTH,ROWS_P) GWAVE3A.385
*ELSE AJC1F405.218
DO I=1,LAND_POINTS AJC1F405.219
STRESS_VD(START_U+LAND_INDEX(I),KOUT_V)= AJC1F405.220
& STRESS_VD_LAND(I,K) AJC1F405.221
END DO AJC1F405.222
*ENDIF AJC1F405.223
ENDIF GWAVE3A.386
ENDIF GWAVE3A.387
GWAVE3A.388
END DO ! K=Start_level,Levels+1 GWAVE3A.389
GWAVE3A.390
ENDIF ! stress_ud/vd on GWAVE3A.391
GWAVE3A.392
IF (DU_DT_SATN_ON .OR. DV_DT_SATN_ON) THEN GWAVE3A.393
GWAVE3A.394
KOUT_U=0 GWAVE3A.395
KOUT_V=0 GWAVE3A.396
DO K=1,LEVELS GWAVE3A.397
GWAVE3A.398
IF(DU_DT_SATN_ON ) THEN GWAVE3A.399
IF(U_LIST2(K)) THEN GWAVE3A.400
KOUT_U=KOUT_U+1 GWAVE3A.401
! Fujitsu vectorization directive GRB0F405.329
!OCL NOVREC GRB0F405.330
CDIR$ IVDEP GWAVE3A.402
*IF -DEF,SCMA AJC1F405.224
DO I=1,LAND_POINTS GWAVE3A.403
WORK(LAND_INDEX(I),1)=DU_DT_SATN_LAND(I,K) GWAVE3A.404
END DO GWAVE3A.405
CALL P_TO_UV(WORK(1,1),DU_DT_SATN(START_U1+1,KOUT_U), ASW1F405.36
* P_POINTS,U_POINTS,ROW_LENGTH,ROWS_P) GWAVE3A.407
*ELSE AJC1F405.225
DO I=1,LAND_POINTS AJC1F405.226
DU_DT_SATN(START_U+LAND_INDEX(I),KOUT_U)= AJC1F405.227
& DU_DT_SATN_LAND(I,K) AJC1F405.228
END DO AJC1F405.229
*ENDIF AJC1F405.230
ENDIF GWAVE3A.408
ENDIF GWAVE3A.409
GWAVE3A.410
IF(DV_DT_SATN_ON ) THEN GWAVE3A.411
IF(V_LIST2(K)) THEN GWAVE3A.412
KOUT_V=KOUT_V+1 GWAVE3A.413
! Fujitsu vectorization directive GRB0F405.331
!OCL NOVREC GRB0F405.332
CDIR$ IVDEP GWAVE3A.414
*IF -DEF,SCMA AJC1F405.231
DO I=1,LAND_POINTS GWAVE3A.415
WORK(LAND_INDEX(I),2)=DV_DT_SATN_LAND(I,K) GWAVE3A.416
END DO GWAVE3A.417
CALL P_TO_UV(WORK(1,2),DV_DT_SATN(START_U1+1,KOUT_V), ASW1F405.37
* P_POINTS,U_POINTS,ROW_LENGTH,ROWS_P) GWAVE3A.419
*ELSE AJC1F405.232
DO I=1,LAND_POINTS AJC1F405.233
DV_DT_SATN(START_U+LAND_INDEX(I),KOUT_V)= AJC1F405.234
& DV_DT_SATN_LAND(I,K) AJC1F405.235
END DO AJC1F405.236
*ENDIF AJC1F405.237
ENDIF GWAVE3A.420
ENDIF GWAVE3A.421
GWAVE3A.422
END DO ! K=Start_level,Levels GWAVE3A.423
GWAVE3A.424
ENDIF ! du/dv_dt_satn on GWAVE3A.425
GWAVE3A.426
IF (DU_DT_JUMP_ON .OR. DV_DT_JUMP_ON) THEN GWAVE3A.427
GWAVE3A.428
KOUT_U=0 GWAVE3A.429
KOUT_V=0 GWAVE3A.430
DO K=1,LEVELS GWAVE3A.431
GWAVE3A.432
IF(DU_DT_JUMP_ON ) THEN GWAVE3A.433
IF(U_LIST3(K)) THEN GWAVE3A.434
KOUT_U=KOUT_U+1 GWAVE3A.435
! Fujitsu vectorization directive GRB0F405.333
!OCL NOVREC GRB0F405.334
CDIR$ IVDEP GWAVE3A.436
*IF -DEF,SCMA AJC1F405.238
DO I=1,LAND_POINTS GWAVE3A.437
WORK(LAND_INDEX(I),1)=DU_DT_JUMP_LAND(I,K) GWAVE3A.438
END DO GWAVE3A.439
CALL P_TO_UV(WORK(1,1),DU_DT_JUMP(START_U1+1,KOUT_U), ASW1F405.38
* P_POINTS,U_POINTS,ROW_LENGTH,ROWS_P) GWAVE3A.441
*ELSE AJC1F405.239
DO I=1,LAND_POINTS AJC1F405.240
DU_DT_JUMP(START_U+LAND_INDEX(I),KOUT_U)= AJC1F405.241
& DU_DT_JUMP_LAND(I,K) AJC1F405.242
END DO AJC1F405.243
*ENDIF AJC1F405.244
ENDIF GWAVE3A.442
ENDIF GWAVE3A.443
GWAVE3A.444
IF(DV_DT_JUMP_ON ) THEN GWAVE3A.445
IF(V_LIST3(K)) THEN GWAVE3A.446
KOUT_V=KOUT_V+1 GWAVE3A.447
! Fujitsu vectorization directive GRB0F405.335
!OCL NOVREC GRB0F405.336
CDIR$ IVDEP GWAVE3A.448
*IF -DEF,SCMA AJC1F405.245
DO I=1,LAND_POINTS GWAVE3A.449
WORK(LAND_INDEX(I),2)=DV_DT_JUMP_LAND(I,K) GWAVE3A.450
END DO GWAVE3A.451
CALL P_TO_UV(WORK(1,2),DV_DT_JUMP(START_U1+1,KOUT_V), ASW1F405.39
* P_POINTS,U_POINTS,ROW_LENGTH,ROWS_P) GWAVE3A.453
*ELSE AJC1F405.246
DO I=1,LAND_POINTS AJC1F405.247
DV_DT_JUMP(START_U+LAND_INDEX(I),KOUT_V)= AJC1F405.248
& DV_DT_JUMP_LAND(I,K) AJC1F405.249
END DO AJC1F405.250
AJC1F405.251
*ENDIF AJC1F405.252
ENDIF GWAVE3A.454
ENDIF GWAVE3A.455
GWAVE3A.456
END DO ! K=Start_level,Levels GWAVE3A.457
GWAVE3A.458
ENDIF ! du/dv_dt_jump on GWAVE3A.459
GWAVE3A.460
IF (DU_DT_LEE_ON .OR. DV_DT_LEE_ON) THEN GWAVE3A.461
GWAVE3A.462
KOUT_U=0 GWAVE3A.463
KOUT_V=0 GWAVE3A.464
DO K=1,LEVELS GWAVE3A.465
GWAVE3A.466
IF(DU_DT_LEE_ON ) THEN GWAVE3A.467
IF(U_LIST4(K)) THEN GWAVE3A.468
KOUT_U=KOUT_U+1 GWAVE3A.469
! Fujitsu vectorization directive GRB0F405.337
!OCL NOVREC GRB0F405.338
CDIR$ IVDEP GWAVE3A.470
*IF -DEF,SCMA AJC1F405.253
DO I=1,LAND_POINTS GWAVE3A.471
WORK(LAND_INDEX(I),1)=DU_DT_LEE_LAND(I,K) GWAVE3A.472
END DO GWAVE3A.473
CALL P_TO_UV(WORK(1,1),DU_DT_LEE(START_U1+1,KOUT_U), ASW1F405.40
* P_POINTS,U_POINTS,ROW_LENGTH,ROWS_P) GWAVE3A.475
*ELSE AJC1F405.254
DO I=1,LAND_POINTS AJC1F405.255
DU_DT_LEE(START_U+LAND_INDEX(I),KOUT_U)= AJC1F405.256
& DU_DT_LEE_LAND(I,K) AJC1F405.257
END DO AJC1F405.258
*ENDIF AJC1F405.259
ENDIF GWAVE3A.476
ENDIF GWAVE3A.477
GWAVE3A.478
IF(DV_DT_LEE_ON ) THEN GWAVE3A.479
IF(V_LIST4(K)) THEN GWAVE3A.480
KOUT_V=KOUT_V+1 GWAVE3A.481
! Fujitsu vectorization directive GRB0F405.339
!OCL NOVREC GRB0F405.340
CDIR$ IVDEP GWAVE3A.482
*IF -DEF,SCMA AJC1F405.260
DO I=1,LAND_POINTS GWAVE3A.483
WORK(LAND_INDEX(I),2)=DV_DT_LEE_LAND(I,K) GWAVE3A.484
END DO GWAVE3A.485
CALL P_TO_UV(WORK(1,2),DV_DT_LEE(START_U1+1,KOUT_V), ASW1F405.41
* P_POINTS,U_POINTS,ROW_LENGTH,ROWS_P) GWAVE3A.487
*ELSE AJC1F405.261
DO I=1,LAND_POINTS AJC1F405.262
DV_DT_LEE(START_U+LAND_INDEX(I),KOUT_V)= AJC1F405.263
& DV_DT_LEE_LAND(I,K) AJC1F405.264
END DO AJC1F405.265
*ENDIF AJC1F405.266
ENDIF GWAVE3A.488
ENDIF GWAVE3A.489
GWAVE3A.490
END DO ! K=Start_level,Levels GWAVE3A.491
GWAVE3A.492
ENDIF ! du/dv_dt_lee on GWAVE3A.493
GWAVE3A.494
IF( TRANS_D_ON ) THEN GWAVE3A.495
*IF -DEF,SCMA AJC1F405.267
DO I=1,LAND_POINTS GWAVE3A.496
WORK(LAND_INDEX(I),2)=TRANS_D_LAND(I) GWAVE3A.497
END DO GWAVE3A.498
CALL P_TO_UV(WORK(1,2),TRANS_D(START_U1+1), ASW1F405.42
* P_POINTS,U_POINTS,ROW_LENGTH,ROWS_P) GWAVE3A.500
*ELSE AJC1F405.268
DO I=1,LAND_POINTS AJC1F405.269
TRANS_D(START_U+LAND_INDEX(I))= AJC1F405.270
& TRANS_D_LAND(I) AJC1F405.271
END DO AJC1F405.272
*ENDIF AJC1F405.273
ENDIF GWAVE3A.501
GWAVE3A.502
IRET=0 GWAVE3A.503
GWAVE3A.504
RETURN GWAVE3A.505
END GWAVE3A.506
GWAVE3A.507
*ENDIF GWAVE3A.508