SUBROUTINE PROPAGS (F1, F3, IG, irefra, ishallo, idelpro, 1PROPAGS.4
*CALL ARGWVAL 
PROPAGS.5
*CALL ARGWVFD PROPAGS.6
*CALL ARGWVGD PROPAGS.7
*CALL ARGWVMP PROPAGS.8
*CALL ARGWVRF PROPAGS.9
*CALL ARGWVSH PROPAGS.10
*CALL ARGWVCU PROPAGS.11
*CALL ARGWVKL PROPAGS.12
*CALL ARGWVP2 PROPAGS.13
& icode) PROPAGS.14
PROPAGS.15
*CALL PARWVSH PROPAGS.16
*CALL PARCONS PROPAGS.17
PROPAGS.18
*CALL TYPWVFD PROPAGS.19
*CALL TYPWVGD PROPAGS.20
*CALL TYPWVMP PROPAGS.21
*CALL TYPWVRF PROPAGS.22
*CALL TYPWVSH PROPAGS.23
*CALL TYPWVCU PROPAGS.24
*CALL TYPWVKL PROPAGS.25
*CALL TYPWVP2 PROPAGS.26
*CALL TYPWVAL PROPAGS.27
PROPAGS.28
C ---------------------------------------------------------------------- PROPAGS.29
C PROPAGS.30
C**** *PROPAGS* - COMPUTATION OF A PROPAGATION TIME STEP. PROPAGS.31
C PROPAGS.32
C S.D. HASSELMANN. PROPAGS.33
C OPTIMIZED BY: L. ZAMBRESKY AND H. GUENTHER PROPAGS.34
C PROPAGS.35
C MODIFIED BY H. GUNTHER 01/06/90 - LAND POINTS ARE TAKEN PROPAGS.36
C OUT OF BLOCKS AND REFRACTION INTEGRATION PROPAGS.37
C CORRECTED FOR N-S AND S-N PROPAGATION. PROPAGS.38
C PROPAGS.39
C K.P. HUBBERT /07/89 - DEPTH AND CURRENT PROPAGS.40
C S. HASSELMANN MPIFM /04/90 REFRACTION SHALLOW PROPAGS.41
C PROPAGS.42
C H. GUNTHER GKSS/ECMWF 17/01/91 - MODIFIED FOR CYCLE_4 PROPAGS.43
C PROPAGS.44
C* PURPOSE. PROPAGS.45
C -------- PROPAGS.46
C PROPAGS.47
C COMPUTATION OF A PROPAGATION TIME STEP. PROPAGS.48
C PROPAGS.49
C** INTERFACE. PROPAGS.50
C ---------- PROPAGS.51
C PROPAGS.52
C *CALL* *PROPAGS(F1, F3, IG)* PROPAGS.53
C *F1* - SPECTRUM AT TIME T. PROPAGS.54
C *F3* - SPECTRUM AT TIME T+DELT. PROPAGS.55
C *IG* - BLOCK NUMBER. PROPAGS.56
C PROPAGS.57
C METHOD. PROPAGS.58
C ------- PROPAGS.59
C PROPAGS.60
C FIRST ORDER FLUX SCHEME. PROPAGS.61
C PROPAGS.62
C EXTERNALS. PROPAGS.63
C ---------- PROPAGS.64
C PROPAGS.65
C *DOTDC* - READ DOT TERMS FOR REFRACTION AND SCATTER TABLE. PROPAGS.66
C PROPAGS.67
C REFERENCE. PROPAGS.68
C ---------- PROPAGS.69
C PROPAGS.70
C NONE. PROPAGS.71
C PROPAGS.72
C ---------------------------------------------------------------------- PROPAGS.73
C local arrays PROPAGS.74
c PROPAGS.75
DIMENSION F1(0:NIBLO,NANG,NFRE), F3(0:NIBLO,NANG,NFRE) PROPAGS.76
PROPAGS.77
DIMENSION DCO(NIBLO), DP1(NIBLO), DP2(NIBLO) PROPAGS.78
DIMENSION DPN(NIBLO), DPS(NIBLO), DPH(0:NIBLO) PROPAGS.79
DIMENSION DLE(NIBLO), DLW(NIBLO), DLA(0:NIBLO) PROPAGS.80
DIMENSION DOP(NIBLC), DOM(NIBLC) PROPAGS.81
DIMENSION DTP(NIBLO), DTM(NIBLO), DRGP(NIBLO), DRGM(NIBLO), PROPAGS.82
1 DRDP(NIBLD), DRDM(NIBLD), DRCP(NIBLC), DRCM(NIBLC) PROPAGS.83
DIMENSION DTC(NIBLO), CGOND(0:NIBLO) PROPAGS.84
PROPAGS.85
real fconst(nibld,nfre) PROPAGS.86
C PROPAGS.87
C ---------------------------------------------------------------------- PROPAGS.88
C PROPAGS.89
c initialise diagnostics array for this block PROPAGS.90
c PROPAGS.91
do i=1,len_p2 PROPAGS.92
sadv2(i)=0. PROPAGS.93
enddo PROPAGS.94
PROPAGS.95
C* 0. SPECTRUM AT LAND TO ZERO. PROPAGS.96
C ------------------------- PROPAGS.97
C PROPAGS.98
DO 1 M=1,NFRE PROPAGS.99
DO 1 K=1,NANG PROPAGS.100
F3(0,K,M) = 0. PROPAGS.101
F1(0,K,M) = 0. WVV0F401.2
1 CONTINUE PROPAGS.102
CGOND(0) = 0.0 WVV0F401.3
DPH(0) = 0.0 WVV0F401.4
DLA(0) = 0.0 WVV0F401.5
C PROPAGS.103
C* 0.1 READ REFRACTION DOT TERMS. PROPAGS.104
C -------------------------- PROPAGS.105
C PROPAGS.106
c call to dotdc deleted from here. PROPAGS.107
c replaced with arrays held in memory calculated in propdot PROPAGS.108
CCUM PROPAGS.109
cc array thdd is already filled for all blocks in setupwv / propdot PROPAGS.110
cc this following bit of code copied out from dotdc PROPAGS.111
cc PROPAGS.112
cc array indep is filled in wamodel for each block PROPAGS.113
cc and is carried in common argwvsh PROPAGS.114
cc PROPAGS.115
cc WAM use of FCONST is a memory saving trick as FCONST is used PROPAGS.116
cc elsewhere for a different role. The array is redefined in UM wam PROPAGS.117
cc as a local array in this routine and reference to ARGWVSR removed PROPAGS.118
cc from propags argument list PROPAGS.119
ccUM PROPAGS.120
if(irefra.ne.0) then PROPAGS.121
if(ishallo.ne.1) then PROPAGS.122
DO M=1,NFRE PROPAGS.123
DO IJ=IJS(ig),IJL(ig) PROPAGS.124
FCONST(IJ,M) = TSIHKD(INDEP(IJ),M) PROPAGS.125
ENDDO PROPAGS.126
ENDDO PROPAGS.127
endif PROPAGS.128
endif PROPAGS.129
C PROPAGS.130
C* 0.2 SPHERICAL OR CARTESIAN GRID? PROPAGS.131
C ---------------------------- PROPAGS.132
C PROPAGS.133
IF (ICASE.EQ.1) THEN PROPAGS.134
C PROPAGS.135
C* 0.2.1 SPHERICAL GRID. PROPAGS.136
C --------------- PROPAGS.137
C PROPAGS.138
C* 0.2.1.1 COSINE OF LATITUDE. PROPAGS.139
C ------------------- PROPAGS.140
C PROPAGS.141
DO 211 IJ = 1,IJLT(IG) PROPAGS.142
JH = KXLT(IJ,IG) PROPAGS.143
DCO(IJ) = 1./COSPH(JH) PROPAGS.144
211 CONTINUE PROPAGS.145
C PROPAGS.146
C* 0.2.1.2 COMPUTE COS PHI FACTOR FOR ADJOINING GRID POINT. PROPAGS.147
C ------------------------------------------------ PROPAGS.148
C PROPAGS.149
DO 212 IJ = IJS(IG),IJL(IG) PROPAGS.150
JH = KLAT(IJ,1,ig) PROPAGS.151
IF (JH.LE.0) THEN PROPAGS.152
DP1(IJ) = 1. PROPAGS.153
ELSE PROPAGS.154
DP1(IJ) = DCO(IJ)/DCO(JH) PROPAGS.155
ENDIF PROPAGS.156
JH = KLAT(IJ,2,ig) PROPAGS.157
IF (JH.LE.0) THEN PROPAGS.158
DP2(IJ) = 1. PROPAGS.159
ELSE PROPAGS.160
DP2(IJ) = DCO(IJ)/DCO(JH) PROPAGS.161
ENDIF PROPAGS.162
212 CONTINUE PROPAGS.163
IF (IREFRA.NE.2) THEN PROPAGS.164
C PROPAGS.165
C* BRANCH TO 3. IF WITHOUT REFRACTION OR DEPTH. PROPAGS.166
C -------------------------------------------- PROPAGS.167
C PROPAGS.168
GOTO 3000 PROPAGS.169
ELSE PROPAGS.170
C PROPAGS.171
C* BRANCH TO 4. IF DEPTH AND CURRENT REFRACTION. PROPAGS.172
C --------------------------------------------- PROPAGS.173
C PROPAGS.174
GOTO 4000 PROPAGS.175
ENDIF PROPAGS.176
ELSE PROPAGS.177
C PROPAGS.178
C* 0.2.2 CARTESIAN GRID. PROPAGS.179
C --------------- PROPAGS.180
C PROPAGS.181
C* 0.2.2.1 BRANCH TO 2. IF DEPTH AND CURRENT REFRACTION. PROPAGS.182
C --------------------------------------------- PROPAGS.183
C PROPAGS.184
IF (IREFRA.EQ.2) GOTO 2000 PROPAGS.185
ENDIF PROPAGS.186
C PROPAGS.187
C ---------------------------------------------------------------------- PROPAGS.188
C PROPAGS.189
C* 1. PROPAGATION FOR CARTESIAN GRID PROPAGS.190
C* WITHOUT REFRACTION OR DEPTH REFRATION. PROPAGS.191
C -------------------------------------- PROPAGS.192
C PROPAGS.193
1000 CONTINUE PROPAGS.194
C PROPAGS.195
DELPRO = FLOAT(IDELPRO) PROPAGS.196
DELPH0 = DELPRO/DELPHI PROPAGS.197
DELLA0 = DELPRO/DELLAM PROPAGS.198
DELTH0 = 0.25*DELPRO/DELTH PROPAGS.199
C PROPAGS.200
C* 1.1 LOOP OVER DIRECTIONS. PROPAGS.201
C --------------------- PROPAGS.202
C PROPAGS.203
DO 1100 K=1,NANG PROPAGS.204
SD = SINTH(K)*DELLA0 PROPAGS.205
CD = COSTH(K)*DELPH0 PROPAGS.206
C PROPAGS.207
C* 1.1.1 INDEX FOR ADJOINING POINTS. PROPAGS.208
C --------------------------- PROPAGS.209
C PROPAGS.210
IF (SD.LT.0) THEN PROPAGS.211
IJLA = 2 PROPAGS.212
ELSE PROPAGS.213
IJLA = 1 PROPAGS.214
ENDIF PROPAGS.215
IF (CD.LT.0) THEN PROPAGS.216
IJPH = 2 PROPAGS.217
ELSE PROPAGS.218
IJPH = 1 PROPAGS.219
ENDIF PROPAGS.220
C PROPAGS.221
IF (ISHALLO.EQ.1) THEN PROPAGS.222
C PROPAGS.223
C* 1.1.2 DEEP WATER. PROPAGS.224
C ----------- PROPAGS.225
C PROPAGS.226
SD = ABS(SD) PROPAGS.227
CD = ABS(CD) PROPAGS.228
DTH = SD + CD PROPAGS.229
C PROPAGS.230
C* 1.1.2.1 LOOP OVER FREQUENCIES. PROPAGS.231
C ---------------------- PROPAGS.232
C PROPAGS.233
DO 1120 M=1,NFRE PROPAGS.234
C PROPAGS.235
C* 1.1.2.1.1 LOOP OVER GRIDPOINTS. PROPAGS.236
C --------------------- PROPAGS.237
C PROPAGS.238
DTT = 1.- DTH*GOM(M) PROPAGS.239
DNO = CD*GOM(M) PROPAGS.240
DEA = SD*GOM(M) PROPAGS.241
DO 1121 IJ = IJS(IG),IJL(IG) PROPAGS.242
F3(IJ,K,M) = DTT * F1(IJ,K,M ) PROPAGS.243
1 + DNO * F1(KLAT(IJ,IJPH,ig),K ,M) PROPAGS.244
2 + DEA * F1(KLON(IJ,IJLA,ig),K ,M) PROPAGS.245
1121 CONTINUE PROPAGS.246
C PROPAGS.247
C* BRANCH BACK TO 1.1.2.1 FOR NEXT FREQUENCY. PROPAGS.248
C PROPAGS.249
1120 CONTINUE PROPAGS.250
ELSE PROPAGS.251
CSHALLOW PROPAGS.252
C PROPAGS.253
C* 1.1.3 SHALLOW WATER. PROPAGS.254
C -------------- PROPAGS.255
C PROPAGS.256
SD = 0.5*SD PROPAGS.257
CD = 0.5*CD PROPAGS.258
C PROPAGS.259
C* 1.1.3.1 DEPTH REFRACTION. PROPAGS.260
C ----------------- PROPAGS.261
C PROPAGS.262
IF(IREFRA.EQ.1) THEN PROPAGS.263
KP1 = K+1 PROPAGS.264
IF (KP1.GT.NANG) KP1 = 1 PROPAGS.265
KM1 = K-1 PROPAGS.266
IF (KM1.LT.1) KM1 = NANG PROPAGS.267
DO 1131 IJ = IJS(IG),IJL(IG) PROPAGS.268
DRDP(IJ) = (THDD(IJ,K,ig) + THDD(IJ,KP1,ig))*DELTH0 PROPAGS.269
DRDM(IJ) = (THDD(IJ,K,ig) + THDD(IJ,KM1,ig))*DELTH0 PROPAGS.270
1131 CONTINUE PROPAGS.271
ENDIF PROPAGS.272
C PROPAGS.273
C* 1.1.3.2 LOOP OVER FREQUENCIES. PROPAGS.274
C ---------------------- PROPAGS.275
C PROPAGS.276
DO 1130 M=1,NFRE PROPAGS.277
C PROPAGS.278
C* 1.1.3.2.1 GROUP VELOCITIES. PROPAGS.279
C ----------------- PROPAGS.280
C PROPAGS.281
CGOND(0) = TCGOND(NDEPTH,M) PROPAGS.282
DO 1132 IJ=1,IJLT(IG) PROPAGS.283
CGOND(IJ) = TCGOND(INDEP(IJ),M) PROPAGS.284
1132 CONTINUE PROPAGS.285
C PROPAGS.286
C* 1.1.3.2.2 WEIGHTS IN INTEGRATION SCHEME. PROPAGS.287
C ------------------------------ PROPAGS.288
C PROPAGS.289
IF (SD.GE.0.) THEN PROPAGS.290
DO 1133 IJ=IJS(IG),IJL(IG) PROPAGS.291
DLA(IJ) = SD*(CGOND(KLON(IJ,1,ig)) + CGOND(IJ)) PROPAGS.292
DTC(IJ) = SD*(CGOND(KLON(IJ,2,ig)) + CGOND(IJ)) PROPAGS.293
1133 CONTINUE PROPAGS.294
ELSE PROPAGS.295
DO 1134 IJ=IJS(IG),IJL(IG) PROPAGS.296
DLA(IJ) =-SD*(CGOND(KLON(IJ,2,ig)) + CGOND(IJ)) PROPAGS.297
DTC(IJ) =-SD*(CGOND(KLON(IJ,1,ig)) + CGOND(IJ)) PROPAGS.298
1134 CONTINUE PROPAGS.299
ENDIF PROPAGS.300
PROPAGS.301
IF (CD.GE.0.) THEN PROPAGS.302
DO 1135 IJ=IJS(IG),IJL(IG) PROPAGS.303
DPH(IJ) = CD*(CGOND(KLAT(IJ,1,ig)) + CGOND(IJ)) PROPAGS.304
DTC(IJ) = DTC(IJ) PROPAGS.305
1 + CD*(CGOND(KLAT(IJ,2,ig)) + CGOND(IJ)) PROPAGS.306
1135 CONTINUE PROPAGS.307
ELSE PROPAGS.308
DO 1136 IJ=IJS(IG),IJL(IG) PROPAGS.309
DPH(IJ) =-CD*(CGOND(KLAT(IJ,2,ig)) + CGOND(IJ)) PROPAGS.310
DTC(IJ) = DTC(IJ) PROPAGS.311
1 -CD*(CGOND(KLAT(IJ,1,ig)) + CGOND(IJ)) PROPAGS.312
1136 CONTINUE PROPAGS.313
ENDIF PROPAGS.314
IF (IREFRA.EQ.1) THEN PROPAGS.315
DO 1137 IJ = IJS(IG),IJL(IG) PROPAGS.316
DTHP = FCONST(IJ,M)*DRDP(IJ) PROPAGS.317
DTHM = FCONST(IJ,M)*DRDM(IJ) PROPAGS.318
DTC(IJ) = DTC(IJ) + DTHP+ABS(DTHP)-DTHM+ABS(DTHM) PROPAGS.319
DTP(IJ) = -DTHP+ABS(DTHP) PROPAGS.320
DTM(IJ) = DTHM+ABS(DTHM) PROPAGS.321
1137 CONTINUE PROPAGS.322
ENDIF PROPAGS.323
C PROPAGS.324
C* 1.1.3.2.3 LOOP OVER GRIDPOINTS. PROPAGS.325
C --------------------- PROPAGS.326
C PROPAGS.327
DO 1138 IJ = IJS(IG),IJL(IG) PROPAGS.328
F3(IJ,K,M) = (1.-DTC(IJ))*F1(IJ,K,M ) PROPAGS.329
1 + DPH(IJ) * F1(KLAT(IJ,IJPH,ig),K ,M) PROPAGS.330
2 + DLA(IJ) * F1(KLON(IJ,IJLA,ig),K ,M) PROPAGS.331
1138 CONTINUE PROPAGS.332
IF (IREFRA.EQ.1) THEN PROPAGS.333
DO 1139 IJ = IJS(IG),IJL(IG) PROPAGS.334
F3(IJ,K,M) = F3(IJ,K,M ) PROPAGS.335
1 + DTP(IJ) * F1(IJ,KP1,M) PROPAGS.336
2 + DTM(IJ) * F1(IJ,KM1,M) PROPAGS.337
1139 CONTINUE PROPAGS.338
ENDIF PROPAGS.339
C PROPAGS.340
C* BRANCH BACK TO 1.1.3.2 FOR NEXT FREQUENCY. PROPAGS.341
C PROPAGS.342
1130 CONTINUE PROPAGS.343
CSHALLOW PROPAGS.344
ENDIF PROPAGS.345
C PROPAGS.346
C* BRANCH BACK TO 1.1 FOR NEXT DIRECTION. PROPAGS.347
C PROPAGS.348
1100 CONTINUE PROPAGS.349
C PROPAGS.350
C* 1.2 END OF PROPAGATION FOR CARTESIAN GRID PROPAGS.351
C* WITHOUT REFRACTION OR DEPTH REFRACTION, RETURN. PROPAGS.352
C ----------------------------------------------- PROPAGS.353
cc PROPAGS.354
cc here extract propagation source term diagnostics: PROPAGS.355
cc PROPAGS.356
if(len_p2.eq.nang*nfre*niblo) then PROPAGS.357
WRITE(6,*)'extracting diagnostics Sadv' GIE0F403.557
do l=1,nfre PROPAGS.359
do m=1,nang PROPAGS.360
nstart=((l-1)*nang + m-1)*niblo PROPAGS.361
do ip=ijs(ig),ijl(ig) PROPAGS.362
sadv2(nstart+ip)=(F3(ip,m,l) - F1(ip,m,l)) PROPAGS.363
enddo PROPAGS.364
enddo PROPAGS.365
enddo PROPAGS.366
endif PROPAGS.367
PROPAGS.368
PROPAGS.369
RETURN PROPAGS.370
C PROPAGS.371
C ---------------------------------------------------------------------- PROPAGS.372
C PROPAGS.373
C* 2. PROPAGATION FOR CARTESIAN GRID PROPAGS.374
C* WITH DEPTH AND CURRENT REFRACTION. PROPAGS.375
C ---------------------------------- PROPAGS.376
C PROPAGS.377
2000 CONTINUE PROPAGS.378
C PROPAGS.379
DELPRO = FLOAT(IDELPRO) PROPAGS.380
DELPH0 = 0.25*DELPRO/DELPHI PROPAGS.381
DELTH0 = 0.25*DELPRO/DELTH PROPAGS.382
DELLA0 = 0.25*DELPRO/DELLAM PROPAGS.383
DELFR0 = 0.25*DELPRO/(0.1*ZPI) PROPAGS.384
C PROPAGS.385
C* 2.1 LOOP OVER DIRECTIONS. PROPAGS.386
C --------------------- PROPAGS.387
C PROPAGS.388
DO 2100 K=1,NANG PROPAGS.389
KP1 = K+1 PROPAGS.390
IF (KP1.GT.NANG) KP1 = 1 PROPAGS.391
KM1 = K-1 PROPAGS.392
IF (KM1.LT.1) KM1 = NANG PROPAGS.393
SD = SINTH(K)*DELLA0 PROPAGS.394
CD = COSTH(K)*DELPH0 PROPAGS.395
C PROPAGS.396
C* 2.1.1 DEPTH REFRACTION IF SHALLOW WATER. PROPAGS.397
C ---------------------------------- PROPAGS.398
C PROPAGS.399
IF (ISHALLO.NE.1) THEN PROPAGS.400
DO 2101 IJ = IJS(IG),IJL(IG) PROPAGS.401
DRDP(IJ) = (THDD(IJ,K,ig) + THDD(IJ,KP1,ig))*DELTH0 PROPAGS.402
DRDM(IJ) = (THDD(IJ,K,ig) + THDD(IJ,KM1,ig))*DELTH0 PROPAGS.403
2101 CONTINUE PROPAGS.404
ENDIF PROPAGS.405
C PROPAGS.406
C* 2.1.2 CURRENT REFRACTION. PROPAGS.407
C ------------------- PROPAGS.408
C PROPAGS.409
DO 2102 IJ = IJS(IG),IJL(IG) PROPAGS.410
DRCP(IJ) = (THDC(IJ,K,ig) + THDC(IJ,KP1,ig))*DELTH0 PROPAGS.411
DRCM(IJ) = (THDC(IJ,K,ig) + THDC(IJ,KM1,ig))*DELTH0 PROPAGS.412
2102 CONTINUE PROPAGS.413
C PROPAGS.414
C* 2.1.3 LOOP OVER FREQUENCIES. PROPAGS.415
C ---------------------- PROPAGS.416
C PROPAGS.417
DO 2130 M=1,NFRE PROPAGS.418
IF (ISHALLO.EQ.1) THEN PROPAGS.419
C PROPAGS.420
C* 2.1.3.1 DEEP WATER. PROPAGS.421
C ----------- PROPAGS.422
C PROPAGS.423
MP1 = MIN(NFRE,M+1) PROPAGS.424
MM1 = MAX(1,M-1) PROPAGS.425
DFP = PI*2.1*DELFR0 PROPAGS.426
C PROPAGS.427
C* 2.1.3.1.1 GROUP VELOCITIES. PROPAGS.428
C ----------------- PROPAGS.429
C PROPAGS.430
CGS = GOM(M)*SD PROPAGS.431
CGC = GOM(M)*CD PROPAGS.432
C PROPAGS.433
C* 2.1.3.1.2 WEIGHTS IN INTEGRATION SCHEME. PROPAGS.434
C ------------------------------ PROPAGS.435
C PROPAGS.436
DLA(0) = CGS PROPAGS.437
DPH(0) = CGC PROPAGS.438
DO 2131 IJ=1,IJLT(IG) PROPAGS.439
DLA(IJ) = U(IJ,IG)*DELLA0 + CGS PROPAGS.440
DPH(IJ) = V(IJ,IG)*DELPH0 + CGC PROPAGS.441
2131 CONTINUE PROPAGS.442
DO 2132 IJ=IJS(IG),IJL(IG) PROPAGS.443
DLWE = DLA(IJ) + DLA(KLON(IJ,1,ig)) PROPAGS.444
DLEA = DLA(IJ) + DLA(KLON(IJ,2,ig)) PROPAGS.445
DLE(IJ) = -DLEA+ABS(DLEA) PROPAGS.446
DLW(IJ) = DLWE+ABS(DLWE) PROPAGS.447
DTC(IJ) = DLEA+ABS(DLEA)-DLWE+ABS(DLWE) PROPAGS.448
PROPAGS.449
DPSO = DPH(IJ) + DPH(KLAT(IJ,1,ig)) PROPAGS.450
DPNO = DPH(IJ) + DPH(KLAT(IJ,2,ig)) PROPAGS.451
DPN(IJ) = -DPNO+ABS(DPNO) PROPAGS.452
DPS(IJ) = DPSO+ABS(DPSO) PROPAGS.453
DTC(IJ) = DTC(IJ) + DPNO+ABS(DPNO)-DPSO+ABS(DPSO) PROPAGS.454
PROPAGS.455
DTHP = DRCP(IJ) PROPAGS.456
DTHM = DRCM(IJ) PROPAGS.457
DTP(IJ) = -DTHP+ABS(DTHP) PROPAGS.458
DTM(IJ) = DTHM+ABS(DTHM) PROPAGS.459
DTC(IJ) = DTC(IJ) + DTHP+ABS(DTHP)-DTHM+ABS(DTHM) PROPAGS.460
PROPAGS.461
DTHP = sidc(IJ,K,NFRE,ig) * DFP PROPAGS.462
DTC(IJ) = DTC(IJ) + 2.* ABS(DTHP) PROPAGS.463
DOP(IJ) = (-DTHP+ABS(DTHP))/1.1 PROPAGS.464
DOM(IJ) = ( DTHP+ABS(DTHP))*1.1 PROPAGS.465
2132 CONTINUE PROPAGS.466
ELSE PROPAGS.467
CSHALLOW PROPAGS.468
C PROPAGS.469
C* 2.1.3.2 SHALLOW WATER. PROPAGS.470
C -------------- PROPAGS.471
C PROPAGS.472
MP1 = MIN(NFRE,M+1) PROPAGS.473
MM1 = MAX(1,M-1) PROPAGS.474
DFP = DELFR0/FR(M) PROPAGS.475
DFM = DELFR0/FR(MM1) PROPAGS.476
C PROPAGS.477
C* 2.1.3.2.1 GROUP VELOCITIES. PROPAGS.478
C ----------------- PROPAGS.479
C PROPAGS.480
CGOND(0) = TCGOND(NDEPTH,M) PROPAGS.481
DO 2133 IJ=1,IJLT(IG) PROPAGS.482
CGOND(IJ) = TCGOND(INDEP(IJ),M) PROPAGS.483
2133 CONTINUE PROPAGS.484
C PROPAGS.485
C* 2.1.3.2.2 WEIGHTS IN INTEGRATION SCHEME. PROPAGS.486
C ------------------------------ PROPAGS.487
C PROPAGS.488
DLA(0) = SD*CGOND(0) PROPAGS.489
DPH(0) = CD*CGOND(0) PROPAGS.490
DO 2134 IJ=1,IJLT(IG) PROPAGS.491
DLA(IJ) = U(IJ,IG)*DELLA0 + SD*CGOND(IJ) PROPAGS.492
DPH(IJ) = V(IJ,IG)*DELPH0 + CD*CGOND(IJ) PROPAGS.493
2134 CONTINUE PROPAGS.494
DO 2135 IJ=IJS(IG),IJL(IG) PROPAGS.495
DLWE = DLA(IJ) + DLA(KLON(IJ,1,ig)) PROPAGS.496
DLEA = DLA(IJ) + DLA(KLON(IJ,2,ig)) PROPAGS.497
DLE(IJ) = -DLEA+ABS(DLEA) PROPAGS.498
DLW(IJ) = DLWE+ABS(DLWE) PROPAGS.499
DTC(IJ) = DLEA+ABS(DLEA)-DLWE+ABS(DLWE) PROPAGS.500
PROPAGS.501
DPSO = DPH(IJ) + DPH(KLAT(IJ,1,ig)) PROPAGS.502
DPNO = DPH(IJ) + DPH(KLAT(IJ,2,ig)) PROPAGS.503
DPN(IJ) = -DPNO+ABS(DPNO) PROPAGS.504
DPS(IJ) = DPSO+ABS(DPSO) PROPAGS.505
DTC(IJ) = DTC(IJ) + DPNO+ABS(DPNO)-DPSO+ABS(DPSO) PROPAGS.506
PROPAGS.507
DTHP = FCONST(IJ,M)*DRDP(IJ) + DRCP(IJ) PROPAGS.508
DTHM = FCONST(IJ,M)*DRDM(IJ) + DRCM(IJ) PROPAGS.509
DTC(IJ) = DTC(IJ) + DTHP+ABS(DTHP)-DTHM+ABS(DTHM) PROPAGS.510
DTP(IJ) = -DTHP+ABS(DTHP) PROPAGS.511
DTM(IJ) = DTHM+ABS(DTHM) PROPAGS.512
PROPAGS.513
DTHP = (sidc(IJ,K,M,ig) + sidc(IJ,K,MP1,ig))*DFP PROPAGS.514
DTHM = (sidc(IJ,K,M,ig) + sidc(IJ,K,MM1,ig))*DFM PROPAGS.515
DTC(IJ) = DTC(IJ) + DTHP+ABS(DTHP)-DTHM+ABS(DTHM) PROPAGS.516
DOP(IJ) = (-DTHP+ABS(DTHP))/1.1 PROPAGS.517
DOM(IJ) = ( DTHM+ABS(DTHM))*1.1 PROPAGS.518
2135 CONTINUE PROPAGS.519
CSHALLOW PROPAGS.520
ENDIF PROPAGS.521
C PROPAGS.522
C* 2.1.3.3 LOOP OVER GRIDPOINTS. PROPAGS.523
C --------------------- PROPAGS.524
C PROPAGS.525
DO 2136 IJ = IJS(IG),IJL(IG) PROPAGS.526
F3(IJ,K,M) = (1.-DTC(IJ))*F1(IJ,K,M ) PROPAGS.527
1 + DPN(IJ) * F1(KLAT(IJ,2,ig),K ,M) PROPAGS.528
2 + DPS(IJ) * F1(KLAT(IJ,1,ig),K ,M) PROPAGS.529
3 + DLE(IJ) * F1(KLON(IJ,2,ig),K ,M) PROPAGS.530
4 + DLW(IJ) * F1(KLON(IJ,1,ig),K ,M) PROPAGS.531
5 + DTP(IJ) * F1(IJ ,KP1,M) PROPAGS.532
6 + DTM(IJ) * F1(IJ ,KM1,M) PROPAGS.533
7 + DOP(IJ) * F1(IJ ,K ,MP1) PROPAGS.534
8 + DOM(IJ) * F1(IJ ,K ,MM1) PROPAGS.535
2136 CONTINUE PROPAGS.536
C PROPAGS.537
C* BRANCH BACK TO 2.1.3 FOR NEXT FREQUENCY. PROPAGS.538
C PROPAGS.539
2130 CONTINUE PROPAGS.540
C PROPAGS.541
C* BRANCH BACK TO 2.1 FOR NEXT DIRECTION. PROPAGS.542
C PROPAGS.543
2100 CONTINUE PROPAGS.544
C PROPAGS.545
C* 2.2 END OF PROPAGATION FOR CARTESIAN GRID PROPAGS.546
C* WITH DEPTH AND CURRENT REFRACTION, RETURN. PROPAGS.547
C ------------------------------------------ PROPAGS.548
cc PROPAGS.549
cc here extract propagation source term diagnostics: PROPAGS.550
cc PROPAGS.551
if(len_p2.eq.nang*nfre*niblo) then PROPAGS.552
WRITE(6,*)'extracting diagnostics Sadv' GIE0F403.558
do l=1,nfre PROPAGS.554
do m=1,nang PROPAGS.555
nstart=((l-1)*nang + m-1)*niblo PROPAGS.556
do ip=ijs(ig),ijl(ig) PROPAGS.557
sadv2(nstart+ip)=(F3(ip,m,l) - F1(ip,m,l)) PROPAGS.558
enddo PROPAGS.559
enddo PROPAGS.560
enddo PROPAGS.561
endif PROPAGS.562
PROPAGS.563
PROPAGS.564
RETURN PROPAGS.565
C PROPAGS.566
C ---------------------------------------------------------------------- PROPAGS.567
C PROPAGS.568
C* 3. PROPAGATION FOR SPHERICAL LATITUDE/LONGITUDE GRID PROPAGS.569
C* WITHOUT OR DEPTH REFRACTION. PROPAGS.570
C ------------------------------------------------- PROPAGS.571
C PROPAGS.572
3000 CONTINUE PROPAGS.573
C PROPAGS.574
DELPRO = FLOAT(IDELPRO) PROPAGS.575
DELTH0 = 0.25*DELPRO/DELTH PROPAGS.576
DELPH0 = 0.5*DELPRO/DELPHI PROPAGS.577
IF (ISHALLO.EQ.1) THEN PROPAGS.578
DELLA0 = DELPRO/DELLAM PROPAGS.579
ELSE PROPAGS.580
DELLA0 = 0.5*DELPRO/DELLAM PROPAGS.581
ENDIF PROPAGS.582
C PROPAGS.583
C* 3.1 LOOP OVER DIRECTIONS. PROPAGS.584
C --------------------- PROPAGS.585
C PROPAGS.586
DO 3100 K=1,NANG PROPAGS.587
KP1 = K+1 PROPAGS.588
IF (KP1.GT.NANG) KP1 = 1 PROPAGS.589
KM1 = K-1 PROPAGS.590
IF (KM1.LT.1) KM1 = NANG PROPAGS.591
SD = SINTH(K)*DELLA0 PROPAGS.592
CD = COSTH(K)*DELPH0 PROPAGS.593
SDA = ABS(SD) PROPAGS.594
CDA = ABS(CD) PROPAGS.595
C PROPAGS.596
C* 3.1.1 COMPUTE GRID REFRACTION. PROPAGS.597
C ------------------------ PROPAGS.598
C PROPAGS.599
SP = DELTH0*(SINTH(K)+SINTH(KP1))/R PROPAGS.600
SM = DELTH0*(SINTH(K)+SINTH(KM1))/R PROPAGS.601
DO 3101 IJ = IJS(IG),IJL(IG) PROPAGS.602
JH = KXLT(IJ,IG) PROPAGS.603
TANPH = SINPH(JH)*DCO(IJ) PROPAGS.604
DRGP(IJ) = TANPH*SP PROPAGS.605
DRGM(IJ) = TANPH*SM PROPAGS.606
3101 CONTINUE PROPAGS.607
C PROPAGS.608
C* 3.1.2 INDEX FOR ADJOINING POINTS. PROPAGS.609
C --------------------------- PROPAGS.610
C PROPAGS.611
IF (SD.LT.0) THEN PROPAGS.612
IJLA = 2 PROPAGS.613
ELSE PROPAGS.614
IJLA = 1 PROPAGS.615
ENDIF PROPAGS.616
IF (CD.LT.0) THEN PROPAGS.617
IJPH = 2 PROPAGS.618
ELSE PROPAGS.619
IJPH = 1 PROPAGS.620
ENDIF PROPAGS.621
C PROPAGS.622
IF (ISHALLO.EQ.1) THEN PROPAGS.623
C PROPAGS.624
C* 3.1.3 DEEP WATER. PROPAGS.625
C ----------- PROPAGS.626
C PROPAGS.627
C* 3.1.3.1 LAT / LONG WEIGHTS IN INTEGRATION SCHEME. PROPAGS.628
C ----------------------------------------- PROPAGS.629
C PROPAGS.630
DO 3131 IJ=IJS(IG),IJL(IG) PROPAGS.631
DLE(IJ) = DCO(IJ)*SDA PROPAGS.632
3131 CONTINUE PROPAGS.633
IF (CD.GT.0.) THEN PROPAGS.634
DO 3132 IJ=IJS(IG),IJL(IG) PROPAGS.635
DTC(IJ) = DLE(IJ) + CDA*(DP2(IJ) + 1.) PROPAGS.636
DPN(IJ) = CDA*(DP1(IJ) + 1.) PROPAGS.637
3132 CONTINUE PROPAGS.638
ELSE PROPAGS.639
DO 3133 IJ=IJS(IG),IJL(IG) PROPAGS.640
DTC(IJ) = DLE(IJ) + CDA*(DP1(IJ) + 1.) PROPAGS.641
DPN(IJ) = CDA*(DP2(IJ) + 1.) PROPAGS.642
3133 CONTINUE PROPAGS.643
ENDIF PROPAGS.644
C PROPAGS.645
C* 3.1.3.2 REFRACTION WEIGHTS IN INTEGRATION SCHEME. PROPAGS.646
C ----------------------------------------- PROPAGS.647
C PROPAGS.648
DO 3134 IJ=IJS(IG),IJL(IG) PROPAGS.649
DTHP = DRGP(IJ) PROPAGS.650
DTHM = DRGM(IJ) PROPAGS.651
DTC(IJ) = DTC(IJ) + DTHP+ABS(DTHP)-DTHM+ABS(DTHM) PROPAGS.652
DTP(IJ) = -DTHP+ABS(DTHP) PROPAGS.653
DTM(IJ) = DTHM+ABS(DTHM) PROPAGS.654
3134 CONTINUE PROPAGS.655
C PROPAGS.656
C* 3.1.3.3 LOOP OVER FREQUENCIES. PROPAGS.657
C ---------------------- PROPAGS.658
C PROPAGS.659
DO 3135 M=1,NFRE PROPAGS.660
C PROPAGS.661
C* 3.1.3.3.1 LOOP OVER GRIDPOINTS. PROPAGS.662
C --------------------- PROPAGS.663
C PROPAGS.664
DO 3136 IJ = IJS(IG),IJL(IG) PROPAGS.665
DTT = 1. - DTC(IJ)*GOM(M) PROPAGS.666
F3(IJ,K,M) = DTT*F1(IJ,K,M ) + GOM(M) * PROPAGS.667
1 (DPN(IJ) * F1(KLAT(IJ,IJPH,ig),K ,M) PROPAGS.668
2 + DLE(IJ) * F1(KLON(IJ,IJLA,ig),K ,M) PROPAGS.669
3 + DTP(IJ) * F1(IJ ,KP1,M) PROPAGS.670
4 + DTM(IJ) * F1(IJ ,KM1,M)) PROPAGS.671
3136 CONTINUE PROPAGS.672
C PROPAGS.673
C* BRANCH BACK TO 3.1.3.3 FOR NEXT FREQUENCY. PROPAGS.674
C PROPAGS.675
3135 CONTINUE PROPAGS.676
ELSE PROPAGS.677
CSHALLOW PROPAGS.678
C PROPAGS.679
C* 3.1.4 SHALLOW WATER. PROPAGS.680
C -------------- PROPAGS.681
C PROPAGS.682
C PROPAGS.683
C* 3.1.4.1 COMPUTE DEPTH REFRACTION. PROPAGS.684
C ------------------------- PROPAGS.685
C PROPAGS.686
IF (IREFRA.EQ.1) THEN PROPAGS.687
DO 3141 IJ = IJS(IG),IJL(IG) PROPAGS.688
DRDP(IJ) = (THDD(IJ,K,ig) + THDD(IJ,KP1,ig))*DELTH0 PROPAGS.689
DRDM(IJ) = (THDD(IJ,K,ig) + THDD(IJ,KM1,ig))*DELTH0 PROPAGS.690
3141 CONTINUE PROPAGS.691
ENDIF PROPAGS.692
C PROPAGS.693
C* 3.1.4.2 LOOP OVER FREQUENCIES. PROPAGS.694
C ---------------------- PROPAGS.695
C PROPAGS.696
DO 3142 M=1,NFRE PROPAGS.697
C PROPAGS.698
C* 3.1.4.2.1 GROUP VELOCITIES. PROPAGS.699
C ----------------- PROPAGS.700
C PROPAGS.701
CGOND(0) = TCGOND(NDEPTH,M) PROPAGS.702
DO 3143 IJ=1,IJLT(IG) PROPAGS.703
CGOND(IJ) = TCGOND(INDEP(IJ),M) PROPAGS.704
3143 CONTINUE PROPAGS.705
C PROPAGS.706
C* 3.1.4.3.2 LAT / LONG WEIGHTS IN INTEGRATION SCHEME. PROPAGS.707
C ----------------------------------------- PROPAGS.708
C PROPAGS.709
IF (SD.GT.0.) THEN PROPAGS.710
DO 3144 IJ=IJS(IG),IJL(IG) PROPAGS.711
DTC(IJ) = 1. - DCO(IJ)*SDA* PROPAGS.712
1 (CGOND(KLON(IJ,2,ig)) + CGOND(IJ)) PROPAGS.713
DLE(IJ) = DCO(IJ)*SDA* PROPAGS.714
1 (CGOND(KLON(IJ,1,ig)) + CGOND(IJ)) PROPAGS.715
3144 CONTINUE PROPAGS.716
ELSE PROPAGS.717
DO 3145 IJ=IJS(IG),IJL(IG) PROPAGS.718
DTC(IJ) = 1. - DCO(IJ)*SDA* PROPAGS.719
1 (CGOND(KLON(IJ,1,ig)) + CGOND(IJ)) PROPAGS.720
DLE(IJ) = DCO(IJ)*SDA* PROPAGS.721
1 (CGOND(KLON(IJ,2,ig)) + CGOND(IJ)) PROPAGS.722
3145 CONTINUE PROPAGS.723
ENDIF PROPAGS.724
IF (CD.GT.0.) THEN PROPAGS.725
DO 3146 IJ=IJS(IG),IJL(IG) PROPAGS.726
DTC(IJ) = DTC(IJ) - CDA* PROPAGS.727
1 (CGOND(KLAT(IJ,2,ig))*DP2(IJ) + CGOND(IJ)) PROPAGS.728
DPN(IJ) = CDA* PROPAGS.729
1 (CGOND(KLAT(IJ,1,ig))*DP1(IJ) + CGOND(IJ)) PROPAGS.730
3146 CONTINUE PROPAGS.731
ELSE PROPAGS.732
DO 3147 IJ=IJS(IG),IJL(IG) PROPAGS.733
DTC(IJ) = DTC(IJ) - CDA* PROPAGS.734
1 (CGOND(KLAT(IJ,1,ig))*DP1(IJ) + CGOND(IJ)) PROPAGS.735
DPN(IJ) = CDA* PROPAGS.736
1 (CGOND(KLAT(IJ,2,ig))*DP2(IJ) + CGOND(IJ)) PROPAGS.737
3147 CONTINUE PROPAGS.738
ENDIF PROPAGS.739
C PROPAGS.740
C* 3.1.4.2.3 REFRACTION WEIGHTS IN INTEGRATION SCHEME. PROPAGS.741
C ----------------------------------------- PROPAGS.742
C PROPAGS.743
IF (IREFRA.EQ.0) THEN PROPAGS.744
DO 3148 IJ=IJS(IG),IJL(IG) PROPAGS.745
DTHP = DRGP(IJ)*CGOND(IJ) PROPAGS.746
DTHM = DRGM(IJ)*CGOND(IJ) PROPAGS.747
DTC(IJ) = DTC(IJ) - DTHP-ABS(DTHP)+DTHM-ABS(DTHM) PROPAGS.748
DTP(IJ) = -DTHP+ABS(DTHP) PROPAGS.749
DTM(IJ) = DTHM+ABS(DTHM) PROPAGS.750
3148 CONTINUE PROPAGS.751
ELSE PROPAGS.752
DO 3149 IJ=IJS(IG),IJL(IG) PROPAGS.753
DTHP = DRGP(IJ)*CGOND(IJ)+FCONST(IJ,M)*DRDP(IJ) PROPAGS.754
DTHM = DRGM(IJ)*CGOND(IJ)+FCONST(IJ,M)*DRDM(IJ) PROPAGS.755
DTC(IJ) = DTC(IJ) - DTHP-ABS(DTHP)+DTHM-ABS(DTHM) PROPAGS.756
DTP(IJ) = -DTHP+ABS(DTHP) PROPAGS.757
DTM(IJ) = DTHM+ABS(DTHM) PROPAGS.758
3149 CONTINUE PROPAGS.759
ENDIF PROPAGS.760
C PROPAGS.761
C* 3.1.4.2.4 LOOP OVER GRIDPOINTS. PROPAGS.762
C --------------------- PROPAGS.763
C PROPAGS.764
DO 3150 IJ = IJS(IG),IJL(IG) PROPAGS.765
F3(IJ,K,M) = DTC(IJ)*F1(IJ,K,M ) PROPAGS.766
1 + DPN(IJ) * F1(KLAT(IJ,IJPH,ig),K ,M) PROPAGS.767
2 + DLE(IJ) * F1(KLON(IJ,IJLA,ig),K ,M) PROPAGS.768
3 + DTP(IJ) * F1(IJ ,KP1,M) PROPAGS.769
4 + DTM(IJ) * F1(IJ ,KM1,M) PROPAGS.770
3150 CONTINUE PROPAGS.771
C PROPAGS.772
C* BRANCH BACK TO 3.1.4.2 FOR NEXT FREQUENCY. PROPAGS.773
C PROPAGS.774
3142 CONTINUE PROPAGS.775
CSHALLOW PROPAGS.776
ENDIF PROPAGS.777
C PROPAGS.778
C* BRANCH BACK TO 3.1 FOR NEXT DIRECTION. PROPAGS.779
C PROPAGS.780
3100 CONTINUE PROPAGS.781
C PROPAGS.782
C* 3.2 END OF PROPAGATION FOR SPHERICAL GRID PROPAGS.783
C* WITHOUT REFRACTION OR DEPTH REFRACTION, RETURN. PROPAGS.784
C ----------------------------------------------- PROPAGS.785
C PROPAGS.786
cc PROPAGS.787
cc here extract propagation source term diagnostics: PROPAGS.788
cc PROPAGS.789
if(len_p2.eq.nang*nfre*niblo) then PROPAGS.790
WRITE(6,*)'extracting diagnostics Sadv' GIE0F403.559
do l=1,nfre PROPAGS.792
do m=1,nang PROPAGS.793
nstart=((l-1)*nang + m-1)*niblo PROPAGS.794
do ip=ijs(ig),ijl(ig) PROPAGS.795
sadv2(nstart+ip)=(F3(ip,m,l) - F1(ip,m,l)) PROPAGS.796
enddo PROPAGS.797
enddo PROPAGS.798
enddo PROPAGS.799
endif PROPAGS.800
PROPAGS.801
RETURN PROPAGS.802
C PROPAGS.803
C ---------------------------------------------------------------------- PROPAGS.804
C PROPAGS.805
C* 4. PROPAGATION FOR SPHERICAL LATITUDE/LONGITUDE GRID PROPAGS.806
C* WITH DEPTH AND CURRENT REFRACTION. PROPAGS.807
C ------------------------------------------------- PROPAGS.808
C PROPAGS.809
4000 CONTINUE PROPAGS.810
C PROPAGS.811
DELPRO = FLOAT(IDELPRO) PROPAGS.812
DELPH0 = 0.25*DELPRO/DELPHI PROPAGS.813
DELTH0 = 0.25*DELPRO/DELTH PROPAGS.814
DELLA0 = 0.25*DELPRO/DELLAM PROPAGS.815
DELFR0 = 0.25*DELPRO/(0.1*ZPI) PROPAGS.816
C PROPAGS.817
C* 4.1 LOOP OVER DIRECTIONS. PROPAGS.818
C --------------------- PROPAGS.819
C PROPAGS.820
DO 4100 K=1,NANG PROPAGS.821
KP1 = K+1 PROPAGS.822
IF (KP1.GT.NANG) KP1 = 1 PROPAGS.823
KM1 = K-1 PROPAGS.824
IF (KM1.LT.1) KM1 = NANG PROPAGS.825
SD = SINTH(K)*DELLA0 PROPAGS.826
CD = COSTH(K)*DELPH0 PROPAGS.827
C PROPAGS.828
C* 4.1.1 COMPUTE GRID REFRACTION. PROPAGS.829
C ------------------------ PROPAGS.830
C PROPAGS.831
SP = DELTH0*(SINTH(K)+SINTH(KP1))/R PROPAGS.832
SM = DELTH0*(SINTH(K)+SINTH(KM1))/R PROPAGS.833
DO 4111 IJ = IJS(IG),IJL(IG) PROPAGS.834
JH = KXLT(IJ,IG) PROPAGS.835
TANPH = SINPH(JH)*DCO(IJ) PROPAGS.836
DRGP(IJ) = TANPH*SP PROPAGS.837
DRGM(IJ) = TANPH*SM PROPAGS.838
4111 CONTINUE PROPAGS.839
C PROPAGS.840
C* 4.1.2 COMPUTE DEPTH REFRACTION. PROPAGS.841
C ------------------------- PROPAGS.842
C PROPAGS.843
IF (ISHALLO.NE.1) THEN PROPAGS.844
DO 4121 IJ = IJS(IG),IJL(IG) PROPAGS.845
DRDP(IJ) = (THDD(IJ,K,ig) + THDD(IJ,KP1,ig))*DELTH0 PROPAGS.846
DRDM(IJ) = (THDD(IJ,K,ig) + THDD(IJ,KM1,ig))*DELTH0 PROPAGS.847
4121 CONTINUE PROPAGS.848
ENDIF PROPAGS.849
C PROPAGS.850
C* 4.1.3 COMPUTE CURRENT REFRACTION. PROPAGS.851
C --------------------------- PROPAGS.852
C PROPAGS.853
DO 4131 IJ = IJS(IG),IJL(IG) PROPAGS.854
DRCP(IJ) = (THDC(IJ,K,ig) + THDC(IJ,KP1,ig))*DELTH0 PROPAGS.855
DRCM(IJ) = (THDC(IJ,K,ig) + THDC(IJ,KM1,ig))*DELTH0 PROPAGS.856
4131 CONTINUE PROPAGS.857
C PROPAGS.858
C* 4.1.4 LOOP OVER FREQUENCIES. PROPAGS.859
C ---------------------- PROPAGS.860
C PROPAGS.861
DO 4140 M=1,NFRE PROPAGS.862
MP1 = MIN(NFRE,M+1) PROPAGS.863
MM1 = MAX(1,M-1) PROPAGS.864
IF (ISHALLO.EQ.1) THEN PROPAGS.865
C PROPAGS.866
C* 4.1.4.1 DEEP WATER. PROPAGS.867
C ----------- PROPAGS.868
C PROPAGS.869
C* 4.1.4.1.1 GROUP VELOCITIES. PROPAGS.870
C ----------------- PROPAGS.871
C PROPAGS.872
DFP = PI*2.1*DELFR0 PROPAGS.873
CGS = GOM(M)*SD PROPAGS.874
CGC = GOM(M)*CD PROPAGS.875
C PROPAGS.876
C* 4.1.4.1.2 WEIGHTS IN INTEGRATION SCHEME. PROPAGS.877
C ------------------------------ PROPAGS.878
C PROPAGS.879
DLA( 0) = CGS PROPAGS.880
DPH( 0) = CGC PROPAGS.881
DO 4141 IJ=1,IJLT(IG) PROPAGS.882
DLA(IJ) = (U(IJ,IG)*DELLA0 + CGS)*DCO(IJ) PROPAGS.883
DPH(IJ) = V(IJ,IG)*DELPH0 + CGC PROPAGS.884
4141 CONTINUE PROPAGS.885
DO 4142 IJ=IJS(IG),IJL(IG) PROPAGS.886
DLWE = DLA(IJ) + DLA(KLON(IJ,1,ig)) PROPAGS.887
DLEA = DLA(IJ) + DLA(KLON(IJ,2,ig)) PROPAGS.888
DLE(IJ) = -DLEA+ABS(DLEA) PROPAGS.889
DLW(IJ) = DLWE+ABS(DLWE) PROPAGS.890
DTC(IJ) = DLEA+ABS(DLEA)-DLWE+ABS(DLWE) PROPAGS.891
PROPAGS.892
DPSO = DPH(IJ) + DPH(KLAT(IJ,1,ig))*DP1(IJ) PROPAGS.893
DPNO = DPH(IJ) + DPH(KLAT(IJ,2,ig))*DP2(IJ) PROPAGS.894
DPN(IJ) = -DPNO+ABS(DPNO) PROPAGS.895
DPS(IJ) = DPSO+ABS(DPSO) PROPAGS.896
DTC(IJ) = DTC(IJ) + DPNO+ABS(DPNO)-DPSO+ABS(DPSO) PROPAGS.897
PROPAGS.898
DTHP = DRGP(IJ)*GOM(M) + DRCP(IJ) PROPAGS.899
DTHM = DRGM(IJ)*GOM(M) + DRCM(IJ) PROPAGS.900
DTC(IJ) = DTC(IJ) + DTHP+ABS(DTHP)-DTHM+ABS(DTHM) PROPAGS.901
DTP(IJ) = -DTHP+ABS(DTHP) PROPAGS.902
DTM(IJ) = DTHM+ABS(DTHM) PROPAGS.903
PROPAGS.904
DTHP = sidc(IJ,K,NFRE,ig) * DFP PROPAGS.905
DTC(IJ) = DTC(IJ) + 2. * ABS(DTHP) PROPAGS.906
DOP(IJ) = (-DTHP+ABS(DTHP))/1.1 PROPAGS.907
DOM(IJ) = ( DTHP+ABS(DTHP))*1.1 PROPAGS.908
4142 CONTINUE PROPAGS.909
ELSE PROPAGS.910
CSHALLOW PROPAGS.911
C PROPAGS.912
C* 4.1.4.2 SHALLOW WATER. PROPAGS.913
C -------------- PROPAGS.914
C PROPAGS.915
C* 4.1.4.2.1 GROUP VELOCITIES. PROPAGS.916
C ----------------- PROPAGS.917
C PROPAGS.918
DFP = DELFR0/FR(M) PROPAGS.919
DFM = DELFR0/FR(MM1) PROPAGS.920
CGOND(0) = TCGOND(NDEPTH,M) PROPAGS.921
DO 4143 IJ=1,IJLT(IG) PROPAGS.922
CGOND(IJ) = TCGOND(INDEP(IJ),M) PROPAGS.923
4143 CONTINUE PROPAGS.924
C PROPAGS.925
C* 4.1.4.2.2 LON/LAT/DIR WEIGHTS IN INTEGRATION SCHEME. PROPAGS.926
C ------------------------------------------ PROPAGS.927
C PROPAGS.928
DLA( 0) = SD*CGOND(0) PROPAGS.929
DPH( 0) = CD*CGOND(0) PROPAGS.930
DO 4144 IJ=1,IJLT(IG) PROPAGS.931
DLA(IJ) = (U(IJ,IG)*DELLA0 + SD*CGOND(IJ))*DCO(IJ) PROPAGS.932
DPH(IJ) = V(IJ,IG)*DELPH0 + CD*CGOND(IJ) PROPAGS.933
4144 CONTINUE PROPAGS.934
DO 4145 IJ=IJS(IG),IJL(IG) PROPAGS.935
DLWE = DLA(IJ) + DLA(KLON(IJ,1,ig)) PROPAGS.936
DLEA = DLA(IJ) + DLA(KLON(IJ,2,ig)) PROPAGS.937
DLE(IJ) = -DLEA+ABS(DLEA) PROPAGS.938
DLW(IJ) = DLWE+ABS(DLWE) PROPAGS.939
DTC(IJ) = DLEA+ABS(DLEA)-DLWE+ABS(DLWE) PROPAGS.940
PROPAGS.941
DPSO = DPH(IJ) + DPH(KLAT(IJ,1,ig))*DP1(IJ) PROPAGS.942
DPNO = DPH(IJ) + DPH(KLAT(IJ,2,ig))*DP2(IJ) PROPAGS.943
DPN(IJ) = -DPNO+ABS(DPNO) PROPAGS.944
DPS(IJ) = DPSO+ABS(DPSO) PROPAGS.945
DTC(IJ) = DTC(IJ) + DPNO+ABS(DPNO)-DPSO+ABS(DPSO) PROPAGS.946
PROPAGS.947
DTHP=DRGP(IJ)*CGOND(IJ)+FCONST(IJ,M)*DRDP(IJ)+DRCP(IJ) PROPAGS.948
DTHM=DRGM(IJ)*CGOND(IJ)+FCONST(IJ,M)*DRDM(IJ)+DRCM(IJ) PROPAGS.949
DTC(IJ) = DTC(IJ) + DTHP+ABS(DTHP)-DTHM+ABS(DTHM) PROPAGS.950
DTP(IJ) = -DTHP+ABS(DTHP) PROPAGS.951
DTM(IJ) = DTHM+ABS(DTHM) PROPAGS.952
PROPAGS.953
DTHP = (sidc(IJ,K,M,ig) + sidc(IJ,K,MP1,ig))*DFP PROPAGS.954
DTHM = (sidc(IJ,K,M,ig) + sidc(IJ,K,MM1,ig))*DFM PROPAGS.955
DTC(IJ) = DTC(IJ) + DTHP+ABS(DTHP)-DTHM+ABS(DTHM) PROPAGS.956
DOP(IJ) = (-DTHP+ABS(DTHP))/1.1 PROPAGS.957
DOM(IJ) = ( DTHM+ABS(DTHM))*1.1 PROPAGS.958
4145 CONTINUE PROPAGS.959
CSHALLOW PROPAGS.960
ENDIF PROPAGS.961
C PROPAGS.962
C* 4.1.4.3 LOOP OVER GRIDPOINTS. PROPAGS.963
C --------------------- PROPAGS.964
C PROPAGS.965
DO 4146 IJ = IJS(IG),IJL(IG) PROPAGS.966
F3(IJ,K,M) = (1.-DTC(IJ))*F1(IJ,K,M ) PROPAGS.967
1 + DPN(IJ) * F1(KLAT(IJ,2,ig),K ,M) PROPAGS.968
2 + DPS(IJ) * F1(KLAT(IJ,1,ig),K ,M) PROPAGS.969
3 + DLE(IJ) * F1(KLON(IJ,2,ig),K ,M) PROPAGS.970
4 + DLW(IJ) * F1(KLON(IJ,1,ig),K ,M) PROPAGS.971
5 + DTP(IJ) * F1(IJ ,KP1,M) PROPAGS.972
6 + DTM(IJ) * F1(IJ ,KM1,M) PROPAGS.973
7 + DOP(IJ) * F1(IJ ,K ,MP1) PROPAGS.974
8 + DOM(IJ) * F1(IJ ,K ,MM1) PROPAGS.975
4146 CONTINUE PROPAGS.976
C PROPAGS.977
C* BRANCH BACK TO 4.1.4 FOR NEXT FREQUENCY. PROPAGS.978
C PROPAGS.979
4140 CONTINUE PROPAGS.980
C PROPAGS.981
C* BRANCH BACK TO 4.2 FOR NEXT DIRECTION. PROPAGS.982
C PROPAGS.983
4100 CONTINUE PROPAGS.984
C PROPAGS.985
C* 4.4 END OF PROPAGATION FOR SPHERICAL GRID PROPAGS.986
C* WITH DEPTH AND CURRENT REFRACTION, RETURN. PROPAGS.987
C ------------------------------------------ PROPAGS.988
C PROPAGS.989
PROPAGS.990
cc PROPAGS.991
cc here extract propagation source term diagnostics: PROPAGS.992
cc PROPAGS.993
if(len_p2.eq.nang*nfre*niblo) then PROPAGS.994
WRITE(6,*)'extracting diagnostics Sadv' GIE0F403.560
do l=1,nfre PROPAGS.996
do m=1,nang PROPAGS.997
nstart=((l-1)*nang + m-1)*niblo PROPAGS.998
do ip=ijs(ig),ijl(ig) PROPAGS.999
sadv2(nstart+ip)=(F3(ip,m,l) - F1(ip,m,l)) PROPAGS.1000
enddo PROPAGS.1001
enddo PROPAGS.1002
enddo PROPAGS.1003
endif PROPAGS.1004
PROPAGS.1005
PROPAGS.1006
RETURN PROPAGS.1007
END PROPAGS.1008
*ENDIF PROPAGS.1009