module_ADVECTION.F
References to this file elsewhere.
1 !----------------------------------------------------------------------
2 !#define BIT_FOR_BIT
3 !----------------------------------------------------------------------
4 #include "nmm_loop_basemacros.h"
5 #include "nmm_loop_macros.h"
6 !----------------------------------------------------------------------
7 !
8 !NCEP_MESO:MODEL_LAYER: HORIZONTAL AND VERTICAL ADVECTION
9 !
10 !----------------------------------------------------------------------
11 !
12 MODULE MODULE_ADVECTION
13 !
14 !----------------------------------------------------------------------
15 USE MODULE_MODEL_CONSTANTS
16 USE MODULE_EXT_INTERNAL
17 !----------------------------------------------------------------------
18 #ifdef DM_PARALLEL
19 INCLUDE "mpif.h"
20 #endif
21 !----------------------------------------------------------------------
22 !
23 REAL,PARAMETER :: FF2=-0.64813,FF3=0.24520,FF4=-0.12189
24 REAL,PARAMETER :: FFC=1.533,FBC=1.-FFC
25 REAL :: CONSERVE_MIN=0.9,CONSERVE_MAX=1.1
26 !
27 !----------------------------------------------------------------------
28 !*** CRANK-NICHOLSON OFF-CENTER WEIGHTS FOR CURRENT AND FUTURE
29 !*** TIME LEVELS.
30 !-----------------------------------------------------------------------
31 !
32 REAL,PARAMETER :: WGT1=0.90
33 REAL,PARAMETER :: WGT2=2.-WGT1
34 !
35 !*** FOR CRANK_NICHOLSON CHECK ONLY.
36 !
37 INTEGER :: ITEST=47,JTEST=70
38 REAL :: ADTP,ADUP,ADVP,TTLO,TTUP,TULO,TUUP,TVLO,TVUP
39 !
40 !----------------------------------------------------------------------
41 CONTAINS
42 !
43 !***********************************************************************
44 SUBROUTINE ADVE(NTSD,DT,DETA1,DETA2,PDTOP &
45 & ,CURV,F,FAD,F4D,EM_LOC,EMT_LOC,EN,ENT,DX,DY &
46 & ,HTM,HBM2,VTM,VBM2,LMH,LMV &
47 & ,T,U,V,PDSLO,TOLD,UOLD,VOLD &
48 & ,PETDT,UPSTRM &
49 & ,FEW,FNS,FNE,FSE &
50 & ,ADT,ADU,ADV &
51 & ,N_IUP_H,N_IUP_V &
52 & ,N_IUP_ADH,N_IUP_ADV &
53 & ,IUP_H,IUP_V,IUP_ADH,IUP_ADV &
54 & ,IHE,IHW,IVE,IVW,INDX3_WRK &
55 & ,IDS,IDE,JDS,JDE,KDS,KDE &
56 & ,IMS,IME,JMS,JME,KMS,KME &
57 & ,ITS,ITE,JTS,JTE,KTS,KTE)
58 !***********************************************************************
59 !$$$ SUBPROGRAM DOCUMENTATION BLOCK
60 ! . . .
61 ! SUBPROGRAM: ADVE HORIZONTAL AND VERTICAL ADVECTION
62 ! PRGRMMR: JANJIC ORG: W/NP22 DATE: 93-10-28
63 !
64 ! ABSTRACT:
65 ! ADVE CALCULATES THE CONTRIBUTION OF THE HORIZONTAL AND VERTICAL
66 ! ADVECTION TO THE TENDENCIES OF TEMPERATURE AND WIND AND THEN
67 ! UPDATES THOSE VARIABLES.
68 ! THE JANJIC ADVECTION SCHEME FOR THE ARAKAWA E GRID IS USED
69 ! FOR ALL VARIABLES INSIDE THE FIFTH ROW. AN UPSTREAM SCHEME
70 ! IS USED ON ALL VARIABLES IN THE THIRD, FOURTH, AND FIFTH
71 ! OUTERMOST ROWS. THE ADAMS-BASHFORTH TIME SCHEME IS USED.
72 !
73 ! PROGRAM HISTORY LOG:
74 ! 87-06-?? JANJIC - ORIGINATOR
75 ! 95-03-25 BLACK - CONVERSION FROM 1-D TO 2-D IN HORIZONTAL
76 ! 96-03-28 BLACK - ADDED EXTERNAL EDGE
77 ! 98-10-30 BLACK - MODIFIED FOR DISTRIBUTED MEMORY
78 ! 99-07- JANJIC - CONVERTED TO ADAMS-BASHFORTH SCHEME
79 ! COMBINING HORIZONTAL AND VERTICAL ADVECTION
80 ! 02-02-04 BLACK - ADDED VERTICAL CFL CHECK
81 ! 02-02-05 BLACK - CONVERTED TO WRF FORMAT
82 ! 02-08-29 MICHALAKES - CONDITIONAL COMPILATION OF MPI
83 ! CONVERT TO GLOBAL INDEXING
84 ! 02-09-06 WOLFE - MORE CONVERSION TO GLOBAL INDEXING
85 ! 04-05-29 JANJIC,BLACK - CRANK-NICHOLSON VERTICAL ADVECTION
86 ! 04-11-23 BLACK - THREADED
87 !
88 ! USAGE: CALL ADVE FROM SUBROUTINE SOLVE_NMM
89 ! INPUT ARGUMENT LIST:
90 !
91 ! OUTPUT ARGUMENT LIST:
92 !
93 ! OUTPUT FILES:
94 ! NONE
95 !
96 ! SUBPROGRAMS CALLED:
97 !
98 ! UNIQUE: NONE
99 !
100 ! LIBRARY: NONE
101 !
102 ! ATTRIBUTES:
103 ! LANGUAGE: FORTRAN 90
104 ! MACHINE : IBM SP
105 !$$$
106 !***********************************************************************
107 !-----------------------------------------------------------------------
108 !
109 IMPLICIT NONE
110 !
111 !-----------------------------------------------------------------------
112 !
113 INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
114 & ,IMS,IME,JMS,JME,KMS,KME &
115 & ,ITS,ITE,JTS,JTE,KTS,KTE
116 !
117 INTEGER, DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
118 INTEGER, DIMENSION(JMS:JME),INTENT(IN) :: N_IUP_H,N_IUP_V &
119 & ,N_IUP_ADH,N_IUP_ADV
120 INTEGER, DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: IUP_H,IUP_V &
121 & ,IUP_ADH,IUP_ADV &
122 & ,LMH,LMV
123 !
124 !*** NMM_MAX_DIM is set in configure.wrf and must agree with
125 !*** the value of dimspec q in the Registry/Registry
126 !
127 INTEGER,DIMENSION(-3:3,NMM_MAX_DIM,0:6),INTENT(IN) :: INDX3_WRK
128 !
129 INTEGER,INTENT(IN) :: NTSD
130 !
131 REAL,INTENT(IN) :: DT,DY,EN,ENT,F4D,PDTOP
132 !
133 REAL,DIMENSION(NMM_MAX_DIM),INTENT(IN) :: EM_LOC,EMT_LOC
134 !
135 REAL,DIMENSION(KMS:KME),INTENT(IN) :: DETA1,DETA2
136 !
137 REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: CURV,DX,F,FAD,HBM2 &
138 & ,PDSLO,VBM2
139 !
140 REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: PETDT
141 !
142 REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: HTM,VTM
143 !
144 REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: T,TOLD &
145 & ,U,UOLD &
146 & ,V,VOLD
147 !
148 REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(OUT) :: ADT,ADU &
149 & ,ADV &
150 & ,FEW,FNE &
151 & ,FNS,FSE
152 !
153 !-----------------------------------------------------------------------
154 !
155 !*** LOCAL VARIABLES
156 !
157 LOGICAL :: UPSTRM
158 !
159 INTEGER :: I,IEND,IFP,IFQ,II,IPQ,ISP,ISQ,ISTART &
160 & ,IUP_ADH_J,IVH,IVL &
161 & ,J,J1,JA,JAK,JEND,JGLOBAL,JJ,JKNT,JP2,JSTART &
162 & ,K,KNTI_ADH,KSTART,KSTOP,LMHK,LMVK &
163 & ,N,N_IUPH_J,N_IUPADH_J,N_IUPADV_J
164 !
165 INTEGER :: MY_IS_GLB,MY_IE_GLB,MY_JS_GLB,MY_JE_GLB
166 !
167 INTEGER :: J0_P3,J0_P2,J0_P1,J0_00,J0_M1,J1_P2,J1_P1,J1_00,J1_M1 &
168 & ,J2_P1,J2_00,J2_M1,J3_P2,J3_P1,J3_00 &
169 & ,J4_P1,J4_00,J4_M1,J5_00,J5_M1,J6_P1,J6_00
170 !
171 INTEGER,DIMENSION(ITS-5:ITE+5) :: KBOT_CFL_T,KTOP_CFL_T &
172 & ,KBOT_CFL_U,KTOP_CFL_U &
173 & ,KBOT_CFL_V,KTOP_CFL_V
174 !
175 INTEGER,DIMENSION(ITS-5:ITE+5,KTS:KTE) :: ISPA,ISQA
176 !
177 REAL :: ARRAY3_X,CFL,CFT,CFU,CFV,CMT,CMU,CMV &
178 & ,DPDE_P3,DTE,DTQ &
179 & ,F0,F1,F2,F3,FEW_00,FEW_P1,FNE_X,FNS_P1,FNS_X,FPP,FSE_X &
180 & ,HM,PDOP,PDOPU,PDOPV,PP &
181 & ,PVVLO,PVVLOU,PVVLOV,PVVUP,PVVUPU,PVVUPV &
182 & ,QP,RDP,RDPD,RDPDX,RDPDY,RDPU,RDPV &
183 & ,T_UP,TEMPA,TEMPB,TTA,TTB,U_UP,UDY_P1,UDY_X &
184 & ,VXD_X,VDX_P2,V_UP,VDX_X,VM,VTA,VUA,VVA &
185 & ,VVLO,VVLOU,VVLOV,VVUP,VVUPU,VVUPV
186 !
187 REAL,DIMENSION(ITS-5:ITE+5,KTS:KTE) :: ARRAY0,ARRAY1 &
188 & ,ARRAY2,ARRAY3 &
189 & ,VAD_TEND_T,VAD_TEND_U &
190 & ,VAD_TEND_V
191 !
192 REAL,DIMENSION(ITS-5:ITE+5,KTS:KTE) :: TEW,UEW,VEW
193 !
194 REAL,DIMENSION(KTS:KTE) :: CRT,CRU,CRV,DETA1_PDTOP &
195 & ,RCMT,RCMU,RCMV,RSTT,RSTU,RSTV,TN,UN &
196 & ,VAD_TNDX_T,VAD_TNDX_U,VAD_TNDX_V,VN
197 !
198 REAL,DIMENSION(ITS-5:ITE+5,-1:1) :: PETDTK
199 !
200 REAL,DIMENSION(ITS-5:ITE+5) :: TDN,UDN,VDN
201 !
202 !-----------------------------------------------------------------------
203 !
204 !*** TYPE 0 WORKING ARRAY
205 !
206 REAL,DIMENSION(ITS-5:ITE+5,KMS:KME,-3:3) :: DPDE
207 !
208 !*** TYPE 1 WORKING ARRAY
209 !
210 REAL,DIMENSION(ITS-5:ITE+5,KMS:KME,-2:2) :: TST,UDY,UST,VDX,VST
211 !
212 !*** TYPE 4 WORKING ARRAY
213 !
214 REAL,DIMENSION(ITS-5:ITE+5,KMS:KME,-1:1) :: TNS,UNS,VNS
215 !
216 !*** TYPE 5 WORKING ARRAY
217 !
218 REAL,DIMENSION(ITS-5:ITE+5,KMS:KME,-1:0) :: TNE,UNE,VNE
219 !
220 !*** TYPE 6 WORKING ARRAY
221 !
222 REAL,DIMENSION(ITS-5:ITE+5,KMS:KME, 0:1) :: TSE,USE,VSE
223 !-----------------------------------------------------------------------
224 !-----------------------------------------------------------------------
225 !***********************************************************************
226 !
227 ! DPDE ----- 3
228 ! | J Increasing
229 ! |
230 ! | ^
231 ! FNS ----- 2 |
232 ! | |
233 ! | |
234 ! | |
235 ! VNS ----- 1 |
236 ! |
237 ! |
238 ! |
239 ! ADV ----- 0 ------> Current J
240 ! |
241 ! |
242 ! |
243 ! VNS ----- -1
244 ! |
245 ! |
246 ! |
247 ! FNS ----- -2
248 ! |
249 ! |
250 ! |
251 ! DPDE ----- -3
252 !
253 !***********************************************************************
254 !-----------------------------------------------------------------------
255 !-----------------------------------------------------------------------
256 !
257 ISTART=MYIS_P2
258 IEND=MYIE_P2
259 IF(ITE==IDE)IEND=MYIE-3
260 !
261 DTQ=DT*0.25
262 DTE=DT*(0.5*0.25)
263 !***
264 !*** INITIALIZE SOME WORKING ARRAYS TO ZERO
265 !***
266 DO K=KTS,KTE
267 DO I=ITS-5,ITE+5
268 TEW(I,K)=0.
269 UEW(I,K)=0.
270 VEW(I,K)=0.
271 ENDDO
272 ENDDO
273 !
274 !*** TYPE 0
275 !
276 DO N=-3,3
277 DO K=KTS,KTE
278 DO I=ITS-5,ITE+5
279 DPDE(I,K,N)=0.
280 ENDDO
281 ENDDO
282 ENDDO
283 !
284 !*** TYPE 1
285 !
286 DO N=-2,2
287 DO K=KTS,KTE
288 DO I=ITS-5,ITE+5
289 TST(I,K,N)=0.
290 UST(I,K,N)=0.
291 VST(I,K,N)=0.
292 UDY(I,K,N)=0.
293 VDX(I,K,N)=0.
294 ENDDO
295 ENDDO
296 ENDDO
297 !
298 !*** TYPES 5 AND 6
299 !
300 DO N=-1,0
301 DO K=KTS,KTE
302 DO I=ITS-5,ITE+5
303 TNE(I,K,N)=0.
304 TSE(I,K,N+1)=0.
305 UNE(I,K,N)=0.
306 USE(I,K,N+1)=0.
307 VNE(I,K,N)=0.
308 VSE(I,K,N+1)=0.
309 ENDDO
310 ENDDO
311 ENDDO
312 !-----------------------------------------------------------------------
313 !***
314 !*** PRECOMPUTE DETA1 TIMES PDTOP.
315 !***
316 !-----------------------------------------------------------------------
317 !
318 DO K=KTS,KTE
319 DETA1_PDTOP(K)=DETA1(K)*PDTOP
320 ENDDO
321 !-----------------------------------------------------------------------
322 !***
323 !*** WE NEED THE STARTING AND ENDING J FOR THIS TASK'S INTEGRATION
324 !***
325 !-----------------------------------------------------------------------
326 !
327 JSTART=MYJS2
328 JEND=MYJE2
329 !
330 !-----------------------------------------------------------------------
331 !
332 !*** START THE HORIZONTAL ADVECTION IN THE INITIAL SOUTHERN SLABS.
333 !
334 !-----------------------------------------------------------------------
335 !
336 DO J=-2,1
337 JJ=JSTART+J
338 !$omp parallel do &
339 !$omp& private(i,k)
340 DO K=KTS,KTE
341 DO I=MYIS_P4,MYIE_P4
342 TST(I,K,J)=T(I,K,JJ)*FFC+TOLD(I,K,JJ)*FBC
343 UST(I,K,J)=U(I,K,JJ)*FFC+UOLD(I,K,JJ)*FBC
344 VST(I,K,J)=V(I,K,JJ)*FFC+VOLD(I,K,JJ)*FBC
345 ENDDO
346 ENDDO
347 ENDDO
348 !
349 !-----------------------------------------------------------------------
350 !*** MARCH NORTHWARD THROUGH THE SOUTHERNMOST SLABS TO BEGIN
351 !*** FILLING THE MAIN WORKING ARRAYS WHICH ARE MULTI-DIMENSIONED
352 !*** IN J BECAUSE THEY ARE DIFFERENCED OR AVERAGED IN J.
353 !*** ONLY THE NORTHERNMOST OF EACH OF THE WORKING ARRAYS WILL BE
354 !*** FILLED IN THE PRIMARY INTEGRATION SECTION.
355 !-----------------------------------------------------------------------
356 !
357 J1=-3
358 IF(JTS==JDS)J1=-2 ! Cannot go 3 south from J=2 for south tasks
359 !
360 DO J=J1,2
361 JJ=JSTART+J
362 !
363 !$omp parallel do &
364 !$omp& private(i,k)
365 DO K=KTS,KTE
366 DO I=MYIS_P4,MYIE_P4
367 DPDE(I,K,J)=DETA1_PDTOP(K)+DETA2(K)*PDSLO(I,JJ)
368 ENDDO
369 ENDDO
370 !
371 ENDDO
372 !
373 !-----------------------------------------------------------------------
374 DO J=-2,1
375 JJ=JSTART+J
376 !
377 !$omp parallel do &
378 !$omp& private(i,k)
379 DO K=KTS,KTE
380 DO I=MYIS_P4,MYIE_P4
381 UDY(I,K,J)=U(I,K,JJ)*DY
382 VDX_X=V(I,K,JJ)*DX(I,JJ)
383 FNS(I,K,JJ)=VDX_X*(DPDE(I,K,J-1)+DPDE(I,K,J+1))
384 VDX(I,K,J)=VDX_X
385 ENDDO
386 ENDDO
387 !
388 ENDDO
389 !
390 !-----------------------------------------------------------------------
391 DO J=-2,0
392 JJ=JSTART+J
393 !
394 !$omp parallel do &
395 !$omp& private(i,k,tempa)
396 DO K=KTS,KTE
397 DO I=MYIS_P3,MYIE_P3
398 TEMPA=(UDY(I+IHE(JJ),K,J)+VDX(I+IHE(JJ),K,J)) &
399 & +(UDY(I,K,J+1) +VDX(I,K,J+1))
400 FNE(I,K,JJ)=TEMPA*(DPDE(I,K,J)+DPDE(I+IHE(JJ),K,J+1))
401 ENDDO
402 ENDDO
403 !
404 ENDDO
405 !
406 !-----------------------------------------------------------------------
407 DO J=-1,1
408 JJ=JSTART+J
409 !
410 !$omp parallel do &
411 !$omp& private(i,k,tempb)
412 DO K=KTS,KTE
413 DO I=MYIS_P3,MYIE_P3
414 TEMPB=(UDY(I+IHE(JJ),K,J)-VDX(I+IHE(JJ),K,J)) &
415 & +(UDY(I,K,J-1) -VDX(I,K,J-1))
416 FSE(I,K,JJ)=TEMPB*(DPDE(I,K,J)+DPDE(I+IHE(JJ),K,J-1))
417 ENDDO
418 ENDDO
419 !
420 ENDDO
421 !
422 !-----------------------------------------------------------------------
423 DO J=-1,0
424 JJ=JSTART+J
425 !
426 !$omp parallel do &
427 !$omp& private(fns_x,i,k,udy_x)
428 DO K=KTS,KTE
429 DO I=MYIS1_P3,MYIE1_P3
430 FNS_X=FNS(I,K,JJ)
431 TNS(I,K,J)=FNS_X*(TST(I,K,J+1)-TST(I,K,J-1))
432 !
433 UDY_X=U(I,K,JJ)*DY
434 FEW(I,K,JJ)=UDY_X*(DPDE(I+IVW(JJ),K,J)+DPDE(I+IVE(JJ),K,J))
435 ENDDO
436 ENDDO
437 !
438 !$omp parallel do &
439 !$omp& private(i,k)
440 DO K=KTS,KTE
441 DO I=MYIS1_P4,MYIE1_P4
442 UNS(I,K,J)=(FNS(I+IHW(JJ),K,JJ)+FNS(I+IHE(JJ),K,JJ)) &
443 & *(UST(I,K,J+1)-UST(I,K,J-1))
444 VNS(I,K,J)=(FNS(I,K,JJ-1)+FNS(I,K,JJ+1)) &
445 & *(VST(I,K,J+1)-VST(I,K,J-1))
446 ENDDO
447 ENDDO
448 !
449 ENDDO
450 !
451 !-----------------------------------------------------------------------
452 JJ=JSTART-1
453 !
454 !$omp parallel do &
455 !$omp& private(fne_x,fse_x,i,k)
456 DO K=KTS,KTE
457 DO I=MYIS1_P2,MYIE1_P2
458 FNE_X=FNE(I,K,JJ)
459 TNE(I,K,-1)=FNE_X*(TST(I+IHE(JJ),K,0)-TST(I,K,-1))
460 !
461 FSE_X=FSE(I,K,JJ+1)
462 TSE(I,K,0)=FSE_X*(TST(I+IHE(JJ+1),K,-1)-TST(I,K,0))
463 !
464 UNE(I,K,-1)=(FNE(I+IVW(JJ),K,JJ)+FNE(I+IVE(JJ),K,JJ)) &
465 & *(UST(I+IVE(JJ),K,0)-UST(I,K,-1))
466 USE(I,K,0)=(FSE(I+IVW(JJ+1),K,JJ+1)+FSE(I+IVE(JJ+1),K,JJ+1)) &
467 & *(UST(I+IVE(JJ+1),K,-1)-UST(I,K,0))
468 VNE(I,K,-1)=(FNE(I,K,JJ-1)+FNE(I,K,JJ+1)) &
469 & *(VST(I+IVE(JJ),K,0)-VST(I,K,-1))
470 VSE(I,K,0)=(FSE(I,K,JJ)+FSE(I,K,JJ+2)) &
471 & *(VST(I+IVE(JJ+1),K,-1)-VST(I,K,0))
472 ENDDO
473 ENDDO
474 !
475 JKNT=0
476 !
477 !-----------------------------------------------------------------------
478 !-----------------------------------------------------------------------
479 !
480 main_integration : DO J=JSTART,JEND
481 !
482 !-----------------------------------------------------------------------
483 !-----------------------------------------------------------------------
484 !***
485 !*** SET THE 3RD INDEX IN THE WORKING ARRAYS (SEE SUBROUTINE INIT
486 !*** AND PFDHT DIAGRAMS)
487 !***
488 !*** J[TYPE]_NN WHERE "TYPE" IS THE WORKING ARRAY TYPE SEEN IN THE
489 !*** LOCAL DECLARATION ABOVE (DEPENDENT UPON THE J EXTENT) AND
490 !*** NN IS THE NUMBER OF ROWS NORTH OF THE CENTRAL ROW WHOSE J IS
491 !*** THE CURRENT VALUE OF THE main_integration LOOP.
492 !*** (P3 denotes +3, M1 denotes -1, etc.)
493 !***
494 !-----------------------------------------------------------------------
495 !
496 JKNT=JKNT+1
497 !
498 J0_P3=INDX3_WRK(3,JKNT,0)
499 J0_P2=INDX3_WRK(2,JKNT,0)
500 J0_P1=INDX3_WRK(1,JKNT,0)
501 J0_00=INDX3_WRK(0,JKNT,0)
502 J0_M1=INDX3_WRK(-1,JKNT,0)
503 !
504 J1_P2=INDX3_WRK(2,JKNT,1)
505 J1_P1=INDX3_WRK(1,JKNT,1)
506 J1_00=INDX3_WRK(0,JKNT,1)
507 J1_M1=INDX3_WRK(-1,JKNT,1)
508 !
509 J2_P1=INDX3_WRK(1,JKNT,2)
510 J2_00=INDX3_WRK(0,JKNT,2)
511 J2_M1=INDX3_WRK(-1,JKNT,2)
512 !
513 J3_P2=INDX3_WRK(2,JKNT,3)
514 J3_P1=INDX3_WRK(1,JKNT,3)
515 J3_00=INDX3_WRK(0,JKNT,3)
516 !
517 J4_P1=INDX3_WRK(1,JKNT,4)
518 J4_00=INDX3_WRK(0,JKNT,4)
519 J4_M1=INDX3_WRK(-1,JKNT,4)
520 !
521 J5_00=INDX3_WRK(0,JKNT,5)
522 J5_M1=INDX3_WRK(-1,JKNT,5)
523 !
524 J6_P1=INDX3_WRK(1,JKNT,6)
525 J6_00=INDX3_WRK(0,JKNT,6)
526 !
527 MY_IS_GLB=1 ! make this a noop for global indexing
528 MY_IE_GLB=1 ! make this a noop for global indexing
529 MY_JS_GLB=1 ! make this a noop for global indexing
530 MY_JE_GLB=1 ! make this a noop for global indexing
531
532 !-----------------------------------------------------------------------
533 !
534 !$omp parallel do &
535 !$omp& private(dpde_p3,few_00,fne_x,fns_p1,fse_x,i,k,tempa,tempb &
536 !$omp& ,udy_p1,vdx_p2)
537 vertical_loop_1 : DO K=KTS,KTE
538 !
539 !-----------------------------------------------------------------------
540 !*** EXECUTE HORIZONTAL ADVECTION.
541 !-----------------------------------------------------------------------
542 !
543 DO I=MYIS_P4,MYIE_P4
544 TST(I,K,J1_P2)=T(I,K,J+2)*FFC+TOLD(I,K,J+2)*FBC
545 UST(I,K,J1_P2)=U(I,K,J+2)*FFC+UOLD(I,K,J+2)*FBC
546 VST(I,K,J1_P2)=V(I,K,J+2)*FFC+VOLD(I,K,J+2)*FBC
547 ENDDO
548 !
549 !-----------------------------------------------------------------------
550 !*** MASS FLUXES AND MASS POINT ADVECTION COMPONENTS
551 !-----------------------------------------------------------------------
552 !
553 DO I=MYIS_P4,MYIE_P4
554 !
555 !-----------------------------------------------------------------------
556 !*** THE NS AND EW FLUXES IN THE FOLLOWING LOOP ARE ON V POINTS
557 !*** FOR T.
558 !-----------------------------------------------------------------------
559 !
560 DPDE_P3=DETA1_PDTOP(K)+DETA2(K)*PDSLO(I,J+3)
561 DPDE(I,K,J0_P3)=DPDE_P3
562 !
563 !-----------------------------------------------------------------------
564 UDY(I,K,J1_P2)=U(I,K,J+2)*DY
565 VDX_P2=V(I,K,J+2)*DX(I,J+2)
566 VDX(I,K,J1_P2)=VDX_P2
567 FNS(I,K,J+2)=VDX_P2*(DPDE(I,K,J0_P1)+DPDE_P3)
568 ENDDO
569 !
570 !-----------------------------------------------------------------------
571 DO I=MYIS_P3,MYIE_P3
572 TEMPA=(UDY(I+IHE(J+1),K,J1_P1)+VDX(I+IHE(J+1),K,J1_P1)) &
573 & +(UDY(I,K,J1_P2) +VDX(I,K,J1_P2))
574 FNE(I,K,J+1)=TEMPA*(DPDE(I,K,J0_P1)+DPDE(I+IHE(J+1),K,J0_P2))
575 !
576 !-----------------------------------------------------------------------
577 TEMPB=(UDY(I+IHE(J+2),K,J1_P2)-VDX(I+IHE(J+2),K,J1_P2)) &
578 & +(UDY(I,K,J1_P1) -VDX(I,K,J1_P1))
579 FSE(I,K,J+2)=TEMPB*(DPDE(I,K,J0_P2)+DPDE(I+IHE(J),K,J0_P1))
580 !
581 !-----------------------------------------------------------------------
582 FNS_P1=FNS(I,K,J+1)
583 TNS(I,K,J4_P1)=FNS_P1*(TST(I,K,J1_P2)-TST(I,K,J1_00))
584 !
585 !-----------------------------------------------------------------------
586 UDY_P1=U(I,K,J+1)*DY
587 FEW(I,K,J+1)=UDY_P1*(DPDE(I+IVW(J+1),K,J0_P1) &
588 & +DPDE(I+IVE(J+1),K,J0_P1))
589 FEW_00=FEW(I,K,J)
590 TEW(I,K)=FEW_00*(TST(I+IVE(J),K,J1_00)-TST(I+IVW(J),K,J1_00))
591 !
592 !-----------------------------------------------------------------------
593 !*** THE NE AND SE FLUXES ARE ASSOCIATED WITH H POINTS
594 !*** (ACTUALLY JUST TO THE NE AND SE OF EACH H POINT).
595 !-----------------------------------------------------------------------
596 !
597 FNE_X=FNE(I,K,J)
598 TNE(I,K,J5_00)=FNE_X*(TST(I+IHE(J),K,J1_P1)-TST(I,K,J1_00))
599 !
600 FSE_X=FSE(I,K,J+1)
601 TSE(I,K,J6_P1)=FSE_X*(TST(I+IHE(J+1),K,J1_00)-TST(I,K,J1_P1))
602 ENDDO
603 !
604 !-----------------------------------------------------------------------
605 !*** CALCULATION OF MOMENTUM ADVECTION COMPONENTS
606 !-----------------------------------------------------------------------
607 !-----------------------------------------------------------------------
608 !*** THE NS AND EW FLUXES ARE ON H POINTS FOR U AND V.
609 !-----------------------------------------------------------------------
610 !
611 DO I=MYIS_P2,MYIE_P2
612 UEW(I,K)=(FEW(I+IHW(J),K,J)+FEW(I+IHE(J),K,J)) &
613 & *(UST(I+IHE(J),K,J1_00)-UST(I+IHW(J),K,J1_00))
614 UNS(I,K,J4_P1)=(FNS(I+IHW(J+1),K,J+1) &
615 & +FNS(I+IHE(J+1),K,J+1)) &
616 & *(UST(I,K,J1_P2)-UST(I,K,J1_00))
617 VEW(I,K)=(FEW(I,K,J-1)+FEW(I,K,J+1)) &
618 & *(VST(I+IHE(J),K,J1_00)-VST(I+IHW(J),K,J1_00))
619 VNS(I,K,J4_P1)=(FNS(I,K,J)+FNS(I,K,J+2)) &
620 & *(VST(I,K,J1_P2)-VST(I,K,J1_00))
621 !
622 !-----------------------------------------------------------------------
623 !*** THE FOLLOWING NE AND SE FLUXES ARE TIED TO V POINTS AND ARE
624 !*** LOCATED JUST TO THE NE AND SE OF THE GIVEN I,J.
625 !-----------------------------------------------------------------------
626 !
627 UNE(I,K,J5_00)=(FNE(I+IVW(J),K,J)+FNE(I+IVE(J),K,J)) &
628 & *(UST(I+IVE(J),K,J1_P1)-UST(I,K,J1_00))
629 USE(I,K,J6_P1)=(FSE(I+IVW(J+1),K,J+1) &
630 & +FSE(I+IVE(J+1),K,J+1)) &
631 & *(UST(I+IVE(J+1),K,J1_00)-UST(I,K,J1_P1))
632 VNE(I,K,J5_00)=(FNE(I,K,J-1)+FNE(I,K,J+1)) &
633 & *(VST(I+IVE(J),K,J1_P1)-VST(I,K,J1_00))
634 VSE(I,K,J6_P1)=(FSE(I,K,J)+FSE(I,K,J+2)) &
635 & *(VST(I+IVE(J+1),K,J1_00)-VST(I,K,J1_P1))
636 ENDDO
637 !
638 !-----------------------------------------------------------------------
639 !
640 ENDDO vertical_loop_1
641 !
642 !-----------------------------------------------------------------------
643 !*** COMPUTE THE ADVECTION TENDENCIES FOR T.
644 !*** THE AD ARRAYS ARE ON H POINTS.
645 !*** SKIP TO UPSTREAM IF THESE ROWS HAVE ONLY UPSTREAM POINTS.
646 !-----------------------------------------------------------------------
647 !
648
649 JGLOBAL=J+MY_JS_GLB-1
650 IF(JGLOBAL>=6.AND.JGLOBAL<=JDE-5)THEN
651 !
652 JJ=J+MY_JS_GLB-1 ! okay because MY_JS_GLB is 1
653 IF(ITS==IDS)ISTART=3+MOD(JJ,2) ! need to think about this
654 ! more in terms of how to
655 ! convert to global indexing
656 !
657 !$omp parallel do &
658 !$omp& private(i,k,rdpd)
659 DO K=KTS,KTE
660 DO I=ISTART,IEND
661 RDPD=1./DPDE(I,K,J0_00)
662 !
663 ADT(I,K,J)=(TEW(I+IHW(J),K)+TEW(I+IHE(J),K) &
664 & +TNS(I,K,J4_M1)+TNS(I,K,J4_P1) &
665 & +TNE(I+IHW(J),K,J5_M1)+TNE(I,K,J5_00) &
666 & +TSE(I,K,J6_00)+TSE(I+IHW(J),K,J6_P1)) &
667 & *RDPD*FAD(I,J)
668 !
669 ENDDO
670 ENDDO
671 !
672 !-----------------------------------------------------------------------
673 !*** COMPUTE THE ADVECTION TENDENCIES FOR U AND V.
674 !*** THE AD ARRAYS ARE ON VELOCITY POINTS.
675 !-----------------------------------------------------------------------
676 !
677 IF(ITS==IDS)ISTART=3+MOD(JJ+1,2)
678 !
679 !$omp parallel do &
680 !$omp& private(i,k,rdpdx,rdpdy)
681 DO K=KTS,KTE
682 DO I=ISTART,IEND
683 RDPDX=1./(DPDE(I+IVW(J),K,J0_00)+DPDE(I+IVE(J),K,J0_00))
684 RDPDY=1./(DPDE(I,K,J0_M1)+DPDE(I,K,J0_P1))
685 !
686 ADU(I,K,J)=(UEW(I+IVW(J),K)+UEW(I+IVE(J),K) &
687 & +UNS(I,K,J4_M1)+UNS(I,K,J4_P1) &
688 & +UNE(I+IVW(J),K,J5_M1)+UNE(I,K,J5_00) &
689 & +USE(I,K,J6_00)+USE(I+IVW(J),K,J6_P1)) &
690 & *RDPDX*FAD(I+IVW(J),J)
691 !
692 ADV(I,K,J)=(VEW(I+IVW(J),K)+VEW(I+IVE(J),K) &
693 & +VNS(I,K,J4_M1)+VNS(I,K,J4_P1) &
694 & +VNE(I+IVW(J),K,J5_M1)+VNE(I,K,J5_00) &
695 & +VSE(I,K,J6_00)+VSE(I+IVW(J),K,J6_P1)) &
696 & *RDPDY*FAD(I+IVW(J),J)
697 !
698 ENDDO
699 ENDDO
700 !
701 ENDIF
702 !
703 !-----------------------------------------------------------------------
704 !-----------------------------------------------------------------------
705 !
706 !*** END OF JANJIC HORIZONTAL ADVECTION
707 !
708 !-----------------------------------------------------------------------
709 !-----------------------------------------------------------------------
710 !*** UPSTREAM ADVECTION OF T, U, AND V
711 !-----------------------------------------------------------------------
712 !-----------------------------------------------------------------------
713 !
714 upstream : IF(UPSTRM)THEN
715 !
716 !-----------------------------------------------------------------------
717 !***
718 !*** COMPUTE UPSTREAM COMPUTATIONS ON THIS TASK'S ROWS.
719 !***
720 !-----------------------------------------------------------------------
721 !
722 N_IUPH_J=N_IUP_H(J) ! See explanation in INIT
723 !
724 !$omp parallel do &
725 !$omp& private(array3_x,i,k,pp,qp,tta,ttb)
726 DO K=KTS,KTE
727 !
728 DO II=0,N_IUPH_J-1
729 I=IUP_H(IMS+II,J)
730 TTA=EMT_LOC(J)*(UST(I,K,J1_M1)+UST(I+IHW(J),K,J1_00) &
731 & +UST(I+IHE(J),K,J1_00)+UST(I,K,J1_P1))
732 TTB=ENT *(VST(I,K,J1_M1)+VST(I+IHW(J),K,J1_00) &
733 & +VST(I+IHE(J),K,J1_00)+VST(I,K,J1_P1))
734 PP=-TTA-TTB
735 QP= TTA-TTB
736 !
737 IF(PP<0.)THEN
738 ISPA(I,K)=-1
739 ELSE
740 ISPA(I,K)= 1
741 ENDIF
742 !
743 IF(QP<0.)THEN
744 ISQA(I,K)=-1
745 ELSE
746 ISQA(I,K)= 1
747 ENDIF
748 !
749 PP=ABS(PP)
750 QP=ABS(QP)
751 ARRAY3_X=PP*QP
752 ARRAY0(I,K)=ARRAY3_X-PP-QP
753 ARRAY1(I,K)=PP-ARRAY3_X
754 ARRAY2(I,K)=QP-ARRAY3_X
755 ARRAY3(I,K)=ARRAY3_X
756 ENDDO
757 !
758 ENDDO
759 !-----------------------------------------------------------------------
760 !
761 N_IUPADH_J=N_IUP_ADH(J)
762 !
763 !$omp parallel do &
764 !$omp& private(f0,f1,f2,f3,i,ifp,ifq,ipq,isp,isq,iup_adh_j,k,knti_adh)
765 DO K=KTS,KTE
766 !
767 KNTI_ADH=1
768 IUP_ADH_J=IUP_ADH(IMS,J)
769 !
770 DO II=0,N_IUPH_J-1
771 I=IUP_H(IMS+II,J)
772 !
773 ISP=ISPA(I,K)
774 ISQ=ISQA(I,K)
775 IFP=(ISP-1)/2
776 IFQ=(-ISQ-1)/2
777 IPQ=(ISP-ISQ)/2
778 !
779 IF(HTM(I+IHE(J)+IFP,K,J+ISP) &
780 & *HTM(I+IHE(J)+IFQ,K,J+ISQ) &
781 & *HTM(I+IPQ,K,J+ISP+ISQ)>0.1)THEN
782 GO TO 150
783 ENDIF
784 !
785 IF(HTM(I+IHE(J)+IFP,K,J+ISP) &
786 & +HTM(I+IHE(J)+IFQ,K,J+ISQ) &
787 & +HTM(I+IPQ,K,J+ISP+ISQ)<0.1)THEN
788 !
789 T(I+IHE(J)+IFP,K,J+ISP)=T(I,K,J)
790 T(I+IHE(J)+IFQ,K,J+ISQ)=T(I,K,J)
791 T(I+IPQ,K,J+ISP+ISQ)=T(I,K,J)
792 !
793 ELSEIF &
794 & (HTM(I+IHE(J)+IFP,K,J+ISP)+HTM(I+IPQ,K,J+ISP+ISQ) &
795 & <0.99)THEN
796 !
797 T(I+IHE(J)+IFP,K,J+ISP)=T(I,K,J)
798 T(I+IPQ,K,J+ISP+ISQ)=T(I+IHE(J)+IFQ,K,J+ISQ)
799 !
800 ELSEIF &
801 & (HTM(I+IHE(J)+IFQ,K,J+ISQ)+HTM(I+IPQ,K,J+ISP+ISQ) &
802 <0.99)THEN
803 !
804 T(I+IHE(J)+IFQ,K,J+ISQ)=T(I,K,J)
805 T(I+IPQ,K,J+ISP+ISQ)=T(I+IHE(J)+IFP,K,J+ISP)
806 !
807 ELSEIF &
808 & (HTM(I+IHE(J)+IFP,K,J+ISP) &
809 & +HTM(I+IHE(J)+IFQ,K,J+ISQ)<0.99)THEN
810 T(I+IHE(J)+IFP,K,J+ISP)=0.5*(T(I,K,J) &
811 & +T(I+IPQ,K,J+ISP+ISQ))
812 T(I+IHE(J)+IFQ,K,J+ISQ)=T(I+IHE(J)+IFP,K,J+ISP)
813 !
814 ELSEIF(HTM(I+IHE(J)+IFP,K,J+ISP)<0.99)THEN
815 T(I+IHE(J)+IFP,K,J+ISP)=T(I,K,J) &
816 & +T(I+IPQ,K,J+ISP+ISQ) &
817 & -T(I+IHE(J)+IFQ,K,J+ISQ)
818 !
819 ELSEIF(HTM(I+IHE(J)+IFQ,K,J+ISQ)<0.99)THEN
820 T(I+IHE(J)+IFQ,K,J+ISQ)=T(I,K,J) &
821 & +T(I+IPQ,K,J+ISP+ISQ) &
822 & -T(I+IHE(J)+IFP,K,J+ISP)
823 !
824 ELSE
825 T(I+IPQ,K,J+ISP+ISQ)=T(I+IHE(J)+IFP,K,J+ISP) &
826 & +T(I+IHE(J)+IFQ,K,J+ISQ) &
827 & -T(I,K,J)
828 !
829 ENDIF
830 !
831 150 CONTINUE
832 !
833 !-----------------------------------------------------------------------
834 !
835 IF(I==IUP_ADH_J)THEN ! Update advection H tendencies
836 !
837 ISP=ISPA(I,K)
838 ISQ=ISQA(I,K)
839 IFP=(ISP-1)/2
840 IFQ=(-ISQ-1)/2
841 IPQ=(ISP-ISQ)/2
842 !
843 F0=ARRAY0(I,K)
844 F1=ARRAY1(I,K)
845 F2=ARRAY2(I,K)
846 F3=ARRAY3(I,K)
847 !
848 ADT(I,K,J)=F0*T(I,K,J) &
849 & +F1*T(I+IHE(J)+IFP,K,J+ISP) &
850 & +F2*T(I+IHE(J)+IFQ,K,J+ISQ) &
851 +F3*T(I+IPQ,K,J+ISP+ISQ)
852 !
853 !-----------------------------------------------------------------------
854 !
855 IF(KNTI_ADH<N_IUPADH_J)THEN
856 IUP_ADH_J=IUP_ADH(IMS+KNTI_ADH,J)
857 KNTI_ADH=KNTI_ADH+1
858 ENDIF
859 !
860 ENDIF ! End of advection H tendency IF block
861 !
862 ENDDO ! End of II loop
863 !
864 ENDDO ! End of K loop
865 !
866 !-----------------------------------------------------------------------
867 !-----------------------------------------------------------------------
868 !*** UPSTREAM ADVECTION OF VELOCITY COMPONENTS
869 !-----------------------------------------------------------------------
870 !-----------------------------------------------------------------------
871 !
872 N_IUPADV_J=N_IUP_ADV(J)
873 !
874 !$omp parallel do &
875 !$omp& private(f0,f1,f2,f3,i,ifp,ifq,ipq,isp,isq,k,pp,qp,tta,ttb)
876 DO K=KTS,KTE
877 !
878 DO II=0,N_IUPADV_J-1
879 I=IUP_ADV(IMS+II,J)
880 !
881 TTA=EM_LOC(J)*UST(I,K,J1_00)
882 TTB=EN *VST(I,K,J1_00)
883 PP=-TTA-TTB
884 QP=TTA-TTB
885 !
886 IF(PP<0.)THEN
887 ISP=-1
888 ELSE
889 ISP= 1
890 ENDIF
891 !
892 IF(QP<0.)THEN
893 ISQ=-1
894 ELSE
895 ISQ= 1
896 ENDIF
897 !
898 IFP=(ISP-1)/2
899 IFQ=(-ISQ-1)/2
900 IPQ=(ISP-ISQ)/2
901 PP=ABS(PP)
902 QP=ABS(QP)
903 F3=PP*QP
904 F0=F3-PP-QP
905 F1=PP-F3
906 F2=QP-F3
907 !
908 ADU(I,K,J)=F0*U(I,K,J) &
909 & +F1*U(I+IVE(J)+IFP,K,J+ISP) &
910 & +F2*U(I+IVE(J)+IFQ,K,J+ISQ) &
911 & +F3*U(I+IPQ,K,J+ISP+ISQ)
912 !
913 ADV(I,K,J)=F0*V(I,K,J) &
914 & +F1*V(I+IVE(J)+IFP,K,J+ISP) &
915 & +F2*V(I+IVE(J)+IFQ,K,J+ISQ) &
916 & +F3*V(I+IPQ,K,J+ISP+ISQ)
917 !
918 ENDDO
919 !
920 ENDDO ! End of K loop
921 !
922 !-----------------------------------------------------------------------
923 !
924 ENDIF upstream
925 !
926 !-----------------------------------------------------------------------
927 !-----------------------------------------------------------------------
928 !*** END OF THIS UPSTREAM REGION
929 !-----------------------------------------------------------------------
930 !-----------------------------------------------------------------------
931 !
932 !*** COMPUTE VERTICAL ADVECTION TENDENCIES USING CRANK-NICHOLSON.
933 !
934 !-----------------------------------------------------------------------
935 !*** FIRST THE TEMPERATURE
936 !-----------------------------------------------------------------------
937 !
938 !$omp parallel do &
939 !$omp& private(cft,cmt,crt,i,k,lmhk,pdop,pvvlo,pvvup,rcmt,rdp,rstt,tn &
940 !$omp& ,vvlo,vvup &
941 !!!$omp& ,adtp,ttlo,ttup &
942 !$omp& )
943 iloop_for_t: DO I=MYIS1,MYIE1
944 !
945 PDOP=PDSLO(I,J)
946 PVVLO=PETDT(I,KTE-1,J)*DTQ
947 VVLO=PVVLO/(DETA1_PDTOP(KTE)+DETA2(KTE)*PDOP)
948 CMT=-VVLO*WGT2+1.
949 RCMT(KTE)=1./CMT
950 CRT(KTE)=VVLO*WGT2
951 RSTT(KTE)=-VVLO*WGT1*(T(I,KTE-1,J)-T(I,KTE,J))+T(I,KTE,J)
952 !
953 LMHK=KTE-LMH(I,J)+1
954 DO K=KTE-1,LMHK+1,-1
955 RDP=1./(DETA1_PDTOP(K)+DETA2(K)*PDOP)
956 PVVUP=PVVLO
957 PVVLO=PETDT(I,K-1,J)*DTQ
958 VVUP=PVVUP*RDP
959 VVLO=PVVLO*RDP
960 CFT=-VVUP*WGT2*RCMT(K+1)
961 CMT=-CRT(K+1)*CFT+((VVUP-VVLO)*WGT2+1.)
962 RCMT(K)=1./CMT
963 CRT(K)=VVLO*WGT2
964 RSTT(K)=-RSTT(K+1)*CFT+T(I,K,J) &
965 & -(T(I,K,J)-T(I,K+1,J))*VVUP*WGT1 &
966 & -(T(I,K-1,J)-T(I,K,J))*VVLO*WGT1
967 ENDDO
968 !
969 PVVUP=PVVLO
970 VVUP=PVVUP/(DETA1_PDTOP(LMHK)+DETA2(LMHK)*PDOP)
971 CFT=-VVUP*WGT2*RCMT(LMHK+1)
972 CMT=-CRT(LMHK+1)*CFT+VVUP*WGT2+1.
973 CRT(LMHK)=0.
974 RSTT(LMHK)=-(T(I,LMHK,J)-T(I,LMHK+1,J))*VVUP*WGT1 &
975 & -RSTT(LMHK+1)*CFT+T(I,LMHK,J)
976 TN(LMHK)=RSTT(LMHK)/CMT
977 VAD_TEND_T(I,LMHK)=TN(LMHK)-T(I,LMHK,J)
978 !
979 DO K=LMHK+1,KTE
980 TN(K)=(-CRT(K)*TN(K-1)+RSTT(K))*RCMT(K)
981 VAD_TEND_T(I,K)=TN(K)-T(I,K,J)
982 ENDDO
983 !
984 !-----------------------------------------------------------------------
985 !*** The following section is only for checking the implicit solution
986 !*** using back-substitution. Remove this section otherwise.
987 !-----------------------------------------------------------------------
988 ! if(ntsd<=10.or.ntsd>=6000)then
989 ! IF(I==ITEST.AND.J==JTEST)THEN
990 !!
991 ! PVVLO=PETDT(I,KTE-1,J)*DT*0.25
992 ! VVLO=PVVLO/(DETA1_PDTOP(KTE)+DETA2(KTE)*PDOP)
993 ! TTLO=VVLO*(T(I,KTE-1,J)-T(I,KTE,J) &
994 ! & +TN(KTE-1)-TN(KTE))
995 ! ADTP=TTLO+TN(KTE)-T(I,KTE,J)
996 ! WRITE(0,*)' NTSD=',NTSD,' I=',ITEST,' J=',JTEST,' K=',KTE &
997 ! &, ' ADTP=',ADTP
998 ! WRITE(0,*)' T=',T(I,KTE,J),' TN=',TN(KTE) &
999 ! &, ' VAD_TEND_T=',VAD_TEND_T(I,KTE)
1000 ! WRITE(0,*)' '
1001 !!
1002 ! DO K=KTE-1,LMHK+1,-1
1003 ! RDP=1./(DETA1_PDTOP(K)+DETA2(K)*PDOP)
1004 ! PVVUP=PVVLO
1005 ! PVVLO=PETDT(I,K-1,J)*DT*0.25
1006 ! VVUP=PVVUP*RDP
1007 ! VVLO=PVVLO*RDP
1008 ! TTUP=VVUP*(T(I,K,J)-T(I,K+1,J)+TN(K)-TN(K+1))
1009 ! TTLO=VVLO*(T(I,K-1,J)-T(I,K,J)+TN(K-1)-TN(K))
1010 ! ADTP=TTLO+TTUP+TN(K)-T(I,K,J)
1011 ! WRITE(0,*)' NTSD=',NTSD,' I=',I,' J=',J,' K=',K &
1012 ! &, ' ADTP=',ADTP
1013 ! WRITE(0,*)' T=',T(I,K,J),' TN=',TN(K) &
1014 ! &, ' VAD_TEND_T=',VAD_TEND_T(I,K)
1015 ! WRITE(0,*)' '
1016 ! ENDDO
1017 !!
1018 ! IF(LMHK==KTS)THEN
1019 ! PVVUP=PVVLO
1020 ! VVUP=PVVUP/(DETA1_PDTOP(KTS)+DETA2(KTS)*PDOP)
1021 ! TTUP=VVUP*(T(I,KTS,J)-T(I,KTS+1,J)+TN(KTS)-TN(KTS+1))
1022 ! ADTP=TTUP+TN(KTS)-T(I,KTS,J)
1023 ! WRITE(0,*)' NTSD=',NTSD,' I=',I,' J=',J,' K=',KTS &
1024 ! &, ' ADTP=',ADTP
1025 ! WRITE(0,*)' T=',T(I,KTS,J),' TN=',TN(KTS) &
1026 ! &, ' VAD_TEND_T=',VAD_TEND_T(I,KTS)
1027 ! WRITE(0,*)' '
1028 ! ENDIF
1029 ! ENDIF
1030 ! endif
1031 !
1032 !-----------------------------------------------------------------------
1033 !*** End of check.
1034 !-----------------------------------------------------------------------
1035 !
1036 ENDDO iloop_for_t
1037 !
1038 !-----------------------------------------------------------------------
1039 !*** NOW VERTICAL ADVECTION OF WIND COMPONENTS
1040 !-----------------------------------------------------------------------
1041 !
1042 !$omp parallel do &
1043 !$omp& private(cfu,cfv,cmu,cmv,cru,crv,i,k,lmvk,pdopu,pdopv &
1044 !$omp& ,pvvlou,pvvlov,pvvupu,pvvupv,rcmu,rcmv,rdpu,rdpv &
1045 !$omp& ,rstu,rstv,un,vn,vvlou,vvlov,vvupu,vvupv &
1046 !!!$omp& ,adup,advp,tulo,tuup,tvlo,tvup &
1047 !$omp& )
1048 iloop_for_uv: DO I=MYIS1,MYIE1
1049 !
1050 PDOPU=(PDSLO(I+IVW(J),J)+PDSLO(I+IVE(J),J))*0.5
1051 PDOPV=(PDSLO(I,J-1)+PDSLO(I,J+1))*0.5
1052 PVVLOU=(PETDT(I+IVW(J),KTE-1,J)+PETDT(I+IVE(J),KTE-1,J))*DTE
1053 PVVLOV=(PETDT(I,KTE-1,J-1)+PETDT(I,KTE-1,J+1))*DTE
1054 VVLOU=PVVLOU/(DETA1_PDTOP(KTE)+DETA2(KTE)*PDOPU)
1055 VVLOV=PVVLOV/(DETA1_PDTOP(KTE)+DETA2(KTE)*PDOPV)
1056 CMU=-VVLOU*WGT2+1.
1057 CMV=-VVLOV*WGT2+1.
1058 RCMU(KTE)=1./CMU
1059 RCMV(KTE)=1./CMV
1060 CRU(KTE)=VVLOU*WGT2
1061 CRV(KTE)=VVLOV*WGT2
1062 RSTU(KTE)=-VVLOU*WGT1*(U(I,KTE-1,J)-U(I,KTE,J))+U(I,KTE,J)
1063 RSTV(KTE)=-VVLOV*WGT1*(V(I,KTE-1,J)-V(I,KTE,J))+V(I,KTE,J)
1064 !
1065 LMVK=KTE-LMV(I,J)+1
1066 DO K=KTE-1,LMVK+1,-1
1067 RDPU=1./(DETA1_PDTOP(K)+DETA2(K)*PDOPU)
1068 RDPV=1./(DETA1_PDTOP(K)+DETA2(K)*PDOPV)
1069 PVVUPU=PVVLOU
1070 PVVUPV=PVVLOV
1071 PVVLOU=(PETDT(I+IVW(J),K-1,J)+PETDT(I+IVE(J),K-1,J))*DTE
1072 PVVLOV=(PETDT(I,K-1,J-1)+PETDT(I,K-1,J+1))*DTE
1073 VVUPU=PVVUPU*RDPU
1074 VVUPV=PVVUPV*RDPV
1075 VVLOU=PVVLOU*RDPU
1076 VVLOV=PVVLOV*RDPV
1077 CFU=-VVUPU*WGT2*RCMU(K+1)
1078 CFV=-VVUPV*WGT2*RCMV(K+1)
1079 CMU=-CRU(K+1)*CFU+(VVUPU-VVLOU)*WGT2+1.
1080 CMV=-CRV(K+1)*CFV+(VVUPV-VVLOV)*WGT2+1.
1081 RCMU(K)=1./CMU
1082 RCMV(K)=1./CMV
1083 CRU(K)=VVLOU*WGT2
1084 CRV(K)=VVLOV*WGT2
1085 RSTU(K)=-RSTU(K+1)*CFU+U(I,K,J) &
1086 & -(U(I,K,J)-U(I,K+1,J))*VVUPU*WGT1 &
1087 & -(U(I,K-1,J)-U(I,K,J))*VVLOU*WGT1
1088 RSTV(K)=-RSTV(K+1)*CFV+V(I,K,J) &
1089 & -(V(I,K,J)-V(I,K+1,J))*VVUPV*WGT1 &
1090 & -(V(I,K-1,J)-V(I,K,J))*VVLOV*WGT1
1091 ENDDO
1092 !
1093 RDPU=1./(DETA1_PDTOP(LMVK)+DETA2(LMVK)*PDOPU)
1094 RDPV=1./(DETA1_PDTOP(LMVK)+DETA2(LMVK)*PDOPV)
1095 PVVUPU=PVVLOU
1096 PVVUPV=PVVLOV
1097 VVUPU=PVVUPU*RDPU
1098 VVUPV=PVVUPV*RDPV
1099 CFU=-VVUPU*WGT2*RCMU(LMVK+1)
1100 CFV=-VVUPV*WGT2*RCMV(LMVK+1)
1101 CMU=-CRU(LMVK+1)*CFU+VVUPU*WGT2+1.
1102 CMV=-CRV(LMVK+1)*CFV+VVUPV*WGT2+1.
1103 CRU(LMVK)=0.
1104 CRV(LMVK)=0.
1105 RSTU(LMVK)=-(U(I,LMVK,J)-U(I,LMVK+1,J))*VVUPU*WGT1 &
1106 & -RSTU(LMVK+1)*CFU+U(I,LMVK,J)
1107 RSTV(LMVK)=-(V(I,LMVK,J)-V(I,LMVK+1,J))*VVUPV*WGT1 &
1108 & -RSTV(LMVK+1)*CFV+V(I,LMVK,J)
1109 UN(LMVK)=RSTU(LMVK)/CMU
1110 VN(LMVK)=RSTV(LMVK)/CMV
1111 VAD_TEND_U(I,LMVK)=UN(LMVK)-U(I,LMVK,J)
1112 VAD_TEND_V(I,LMVK)=VN(LMVK)-V(I,LMVK,J)
1113 !
1114 DO K=LMVK+1,KTE
1115 UN(K)=(-CRU(K)*UN(K-1)+RSTU(K))*RCMU(K)
1116 VN(K)=(-CRV(K)*VN(K-1)+RSTV(K))*RCMV(K)
1117 VAD_TEND_U(I,K)=UN(K)-U(I,K,J)
1118 VAD_TEND_V(I,K)=VN(K)-V(I,K,J)
1119 ENDDO
1120 !
1121 !-----------------------------------------------------------------------
1122 !*** The following section is only for checking the implicit solution
1123 !*** using back-substitution. Remove this section otherwise.
1124 !-----------------------------------------------------------------------
1125 !
1126 ! if(ntsd<=10.or.ntsd>=6000)then
1127 ! IF(I==ITEST.AND.J==JTEST)THEN
1128 !!
1129 ! PDOPU=(PDSLO(I+IVW(J),J)+PDSLO(I+IVE(J),J))*0.5
1130 ! PDOPV=(PDSLO(I,J-1)+PDSLO(I,J+1))*0.5
1131 ! PVVLOU=(PETDT(I+IVW(J),KTE-1,J) &
1132 ! & +PETDT(I+IVE(J),KTE-1,J))*DTE
1133 ! PVVLOV=(PETDT(I,KTE-1,J-1) &
1134 ! & +PETDT(I,KTE-1,J+1))*DTE
1135 ! VVLOU=PVVLOU/(DETA1_PDTOP(KTE)+DETA2(KTE)*PDOPU)
1136 ! VVLOV=PVVLOV/(DETA1_PDTOP(KTE)+DETA2(KTE)*PDOPV)
1137 ! TULO=VVLOU*(U(I,KTE-1,J)-U(I,KTE,J)+UN(KTE-1)-UN(KTE))
1138 ! TVLO=VVLOV*(V(I,KTE-1,J)-V(I,KTE,J)+VN(KTE-1)-VN(KTE))
1139 ! ADUP=TULO+UN(KTE)-U(I,KTE,J)
1140 ! ADVP=TVLO+VN(KTE)-V(I,KTE,J)
1141 ! WRITE(0,*)' NTSD=',NTSD,' I=',I,' J=',J,' K=',KTE &
1142 ! &, ' ADUP=',ADUP,' ADVP=',ADVP
1143 ! WRITE(0,*)' U=',U(I,KTE,J),' UN=',UN(KTE) &
1144 ! &, ' VAD_TEND_U=',VAD_TEND_U(I,KTE) &
1145 ! &, ' V=',V(I,KTE,J),' VN=',VN(KTE) &
1146 ! &, ' VAD_TEND_V=',VAD_TEND_V(I,KTE)
1147 ! WRITE(0,*)' '
1148 !!
1149 ! DO K=KTE-1,LMVK+1,-1
1150 ! RDPU=1./(DETA1_PDTOP(K)+DETA2(K)*PDOPU)
1151 ! RDPV=1./(DETA1_PDTOP(K)+DETA2(K)*PDOPV)
1152 ! PVVUPU=PVVLOU
1153 ! PVVUPV=PVVLOV
1154 ! PVVLOU=(PETDT(I+IVW(J),K-1,J) &
1155 ! & +PETDT(I+IVE(J),K-1,J))*DTE
1156 ! PVVLOV=(PETDT(I,K-1,J-1)+PETDT(I,K-1,J+1))*DTE
1157 ! VVUPU=PVVUPU*RDPU
1158 ! VVUPV=PVVUPV*RDPV
1159 ! VVLOU=PVVLOU*RDPU
1160 ! VVLOV=PVVLOV*RDPV
1161 ! TUUP=VVUPU*(U(I,K,J)-U(I,K+1,J)+UN(K)-UN(K+1))
1162 ! TVUP=VVUPV*(V(I,K,J)-V(I,K+1,J)+VN(K)-VN(K+1))
1163 ! TULO=VVLOU*(U(I,K-1,J)-U(I,K,J)+UN(K-1)-UN(K))
1164 ! TVLO=VVLOV*(V(I,K-1,J)-V(I,K,J)+VN(K-1)-VN(K))
1165 ! ADUP=TUUP+TULO+UN(K)-U(I,K,J)
1166 ! ADVP=TVUP+TVLO+VN(K)-V(I,K,J)
1167 ! WRITE(0,*)' NTSD=',NTSD,' I=',ITEST,' J=',JTEST,' K=',K &
1168 ! &, ' ADUP=',ADUP,' ADVP=',ADVP
1169 ! WRITE(0,*)' U=',U(I,K,J),' UN=',UN(K) &
1170 ! &, ' VAD_TEND_U=',VAD_TEND_U(I,K) &
1171 ! &, ' V=',V(I,K,J),' VN=',VN(K) &
1172 ! &, ' VAD_TEND_V=',VAD_TEND_V(I,K)
1173 ! WRITE(0,*)' '
1174 ! ENDDO
1175 !!
1176 ! IF(LMVK==KTS)THEN
1177 ! PVVUPU=PVVLOU
1178 ! PVVUPV=PVVLOV
1179 ! VVUPU=PVVUPU/(DETA1_PDTOP(KTS)+DETA2(KTS)*PDOPU)
1180 ! VVUPV=PVVUPV/(DETA1_PDTOP(KTS)+DETA2(KTS)*PDOPV)
1181 ! TUUP=VVUPU*(U(I,KTS,J)-U(I,KTS+1,J)+UN(KTS)-UN(KTS+1))
1182 ! TVUP=VVUPV*(V(I,KTS,J)-V(I,KTS+1,J)+VN(KTS)-VN(KTS+1))
1183 ! ADUP=TUUP+UN(KTS)-U(I,KTS,J)
1184 ! ADVP=TVUP+VN(KTS)-V(I,KTS,J)
1185 ! WRITE(0,*)' NTSD=',NTSD,' I=',ITEST,' J=',JTEST,' K=',KTS &
1186 ! &, ' ADUP=',ADUP,' ADVP=',ADVP
1187 ! WRITE(0,*)' U=',U(I,KTS,J),' UN=',UN(KTS) &
1188 ! &, ' VAD_TEND_U=',VAD_TEND_U(I,KTS) &
1189 ! &, ' V=',V(I,KTS,J),' VN=',VN(KTS) &
1190 ! &, ' VAD_TEND_V=',VAD_TEND_V(I,KTS)
1191 ! WRITE(0,*)' '
1192 ! ENDIF
1193 ! ENDIF
1194 ! endif
1195 !
1196 !-----------------------------------------------------------------------
1197 !*** End of check.
1198 !-----------------------------------------------------------------------
1199 !
1200 ENDDO iloop_for_uv
1201 !
1202 !-----------------------------------------------------------------------
1203 !
1204 !*** NOW SUM THE VERTICAL AND HORIZONTAL TENDENCIES,
1205 !*** CURVATURE AND CORIOLIS TERMS
1206 !
1207 !-----------------------------------------------------------------------
1208 !
1209 !$omp parallel do &
1210 !$omp& private(fpp,hm,i,k,vm)
1211 DO K=KTS,KTE
1212 DO I=MYIS1,MYIE1
1213 HM=HTM(I,K,J)*HBM2(I,J)
1214 VM=VTM(I,K,J)*VBM2(I,J)
1215 ADT(I,K,J)=(VAD_TEND_T(I,K)+2.*ADT(I,K,J))*HM
1216 !
1217 FPP=CURV(I,J)*2.*UST(I,K,J1_00)+F(I,J)*2.
1218 ADU(I,K,J)=(VAD_TEND_U(I,K)+2.*ADU(I,K,J)+VST(I,K,J1_00)*FPP) &
1219 & *VM
1220 ADV(I,K,J)=(VAD_TEND_V(I,K)+2.*ADV(I,K,J)-UST(I,K,J1_00)*FPP) &
1221 & *VM
1222 ENDDO
1223 ENDDO
1224 !-----------------------------------------------------------------------
1225 !-----------------------------------------------------------------------
1226 !
1227 ENDDO main_integration
1228 !
1229 !-----------------------------------------------------------------------
1230 !-----------------------------------------------------------------------
1231 !
1232 !-----------------------------------------------------------------------
1233 !*** SAVE THE OLD VALUES FOR TIMESTEPPING
1234 !-----------------------------------------------------------------------
1235 !
1236 !$omp parallel do &
1237 !$omp& private(i,j,k)
1238 DO J=MYJS_P4,MYJE_P4
1239 DO K=KTS,KTE
1240 DO I=MYIS_P4,MYIE_P4
1241 TOLD(I,K,J)=T(I,K,J)
1242 UOLD(I,K,J)=U(I,K,J)
1243 VOLD(I,K,J)=V(I,K,J)
1244 ENDDO
1245 ENDDO
1246 ENDDO
1247 !
1248 !-----------------------------------------------------------------------
1249 !*** FINALLY UPDATE THE PROGNOSTIC VARIABLES
1250 !-----------------------------------------------------------------------
1251 !
1252 !$omp parallel do &
1253 !$omp& private(i,j,k)
1254 DO J=MYJS2,MYJE2
1255 DO K=KTS,KTE
1256 DO I=MYIS1,MYIE1
1257 T(I,K,J)=ADT(I,K,J)+T(I,K,J)
1258 U(I,K,J)=ADU(I,K,J)+U(I,K,J)
1259 V(I,K,J)=ADV(I,K,J)+V(I,K,J)
1260 ENDDO
1261 ENDDO
1262 ENDDO
1263 !-----------------------------------------------------------------------
1264 END SUBROUTINE ADVE
1265 !-----------------------------------------------------------------------
1266 !
1267 !***********************************************************************
1268 SUBROUTINE VAD2(NTSD,DT,IDTAD,DX,DY &
1269 & ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP &
1270 & ,HBM2,LMH &
1271 & ,Q,Q2,CWM,PETDT &
1272 & ,N_IUP_H,N_IUP_V &
1273 & ,N_IUP_ADH,N_IUP_ADV &
1274 & ,IUP_H,IUP_V,IUP_ADH,IUP_ADV &
1275 & ,IHE,IHW,IVE,IVW,INDX3_WRK &
1276 & ,IDS,IDE,JDS,JDE,KDS,KDE &
1277 & ,IMS,IME,JMS,JME,KMS,KME &
1278 & ,ITS,ITE,JTS,JTE,KTS,KTE)
1279 !***********************************************************************
1280 !$$$ SUBPROGRAM DOCUMENTATION BLOCK
1281 ! . . .
1282 ! SUBPROGRAM: VAD2 VERTICAL ADVECTION OF H2O SUBSTANCE AND TKE
1283 ! PRGRMMR: JANJIC ORG: W/NP22 DATE: 96-07-19
1284 !
1285 ! ABSTRACT:
1286 ! VAD2 CALCULATES THE CONTRIBUTION OF THE VERTICAL ADVECTION
1287 ! TO THE TENDENCIES OF WATER SUBSTANCE AND TKE AND THEN UPDATES
1288 ! THOSE VARIABLES. AN ANTI-FILTERING TECHNIQUE IS USED.
1289 !
1290 ! PROGRAM HISTORY LOG:
1291 ! 96-07-19 JANJIC - ORIGINATOR
1292 ! 98-11-02 BLACK - MODIFIED FOR DISTRIBUTED MEMORY
1293 ! 99-03-17 TUCCILLO - INCORPORATED MPI_ALLREDUCE FOR GLOBAL SUM
1294 ! 02-02-06 BLACK - CONVERTED TO WRF FORMAT
1295 ! 02-09-06 WOLFE - MORE CONVERSION TO GLOBAL INDEXING
1296 ! 04-11-23 BLACK - THREADED
1297 !
1298 ! USAGE: CALL VAD2 FROM SUBROUTINE SOLVE_NMM
1299 ! INPUT ARGUMENT LIST:
1300 !
1301 ! OUTPUT ARGUMENT LIST
1302 !
1303 ! OUTPUT FILES:
1304 ! NONE
1305 ! SUBPROGRAMS CALLED:
1306 !
1307 ! UNIQUE: NONE
1308 !
1309 ! LIBRARY: NONE
1310 !
1311 ! ATTRIBUTES:
1312 ! LANGUAGE: FORTRAN 90
1313 ! MACHINE : IBM SP
1314 !$$$
1315 !***********************************************************************
1316 !----------------------------------------------------------------------
1317 !
1318 IMPLICIT NONE
1319 !
1320 !----------------------------------------------------------------------
1321 !
1322 INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
1323 & ,IMS,IME,JMS,JME,KMS,KME &
1324 ,ITS,ITE,JTS,JTE,KTS,KTE
1325 !
1326 INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
1327 INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: N_IUP_H,N_IUP_V &
1328 & ,N_IUP_ADH,N_IUP_ADV
1329 INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: IUP_H,IUP_V &
1330 & ,IUP_ADH,IUP_ADV
1331 ! NMM_MAX_DIM is set in configure.wrf and must agree with
1332 ! the value of dimspec q in the Registry/Registry
1333 INTEGER,DIMENSION(-3:3,NMM_MAX_DIM,0:6),INTENT(IN) :: INDX3_WRK
1334 !
1335 INTEGER,INTENT(IN) :: IDTAD,NTSD
1336 !
1337 INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: LMH
1338 !
1339 REAL,INTENT(IN) :: DT,DY,PDTOP
1340 !
1341 REAL,DIMENSION(KMS:KME),INTENT(IN) :: AETA1,AETA2,DETA1,DETA2
1342 !
1343 REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DX,HBM2,PDSL
1344 !
1345 REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: PETDT
1346 !
1347 REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: CWM,Q,Q2
1348 !
1349 !----------------------------------------------------------------------
1350 !
1351 !*** LOCAL VARIABLES
1352 !
1353 REAL,PARAMETER :: FF1=0.525
1354 !
1355 LOGICAL :: BOT,TOP
1356 !
1357 INTEGER :: I,IRECV,J,JFP,JFQ,K,KOFF,LAP,LLAP
1358 !
1359 INTEGER,DIMENSION(KTS:KTE) :: LA
1360 !
1361 REAL*8 :: ADDT,AFRP,D2PQE,D2PQQ,D2PQW,DEP,DETAP,DPDN,DPUP,DQP &
1362 & ,DWP,E00,E4P,EP,EP0,HADDT,HBM2IJ &
1363 & ,Q00,Q4P,QP,QP0 &
1364 & ,RFACEK,RFACQK,RFACWK,RFC,RR &
1365 & ,SUMNE,SUMNQ,SUMNW,SUMPE,SUMPQ,SUMPW &
1366 & ,W00,W4P,WP,WP0
1367 !
1368 REAL,DIMENSION(KTS:KTE) :: AFR,DEL,DQL,DWL,E3,E4,PETDTK &
1369 & ,RFACE,RFACQ,RFACW,Q3,Q4,W3,W4
1370 !
1371 !***********************************************************************
1372 !-----------------------------------------------------------------------
1373 !
1374 ADDT=REAL(IDTAD)*DT
1375 !
1376 !-----------------------------------------------------------------------
1377 !
1378 !$omp parallel do &
1379 !$omp& private(afr,afrp,bot,d2pqe,d2pqq,d2pqw,del,dep,detap,dpdn,dpup &
1380 !$omp& ,dql,dqp,dwl,dwp,e00,e3,e4,e4p,ep,ep0,haddt,i,j,k,koff &
1381 !$omp& ,la,lap,llap,petdtk,q00,q3,q4,q4p,qp,qp0,rfacek,rfacqk &
1382 !$omp& ,rfacwk,rfc,rr,sumne,sumnq,sumnw,sumpe,sumpq,sumpw,top &
1383 !$omp& ,w00,w3,w4,w4p,wp,wp0)
1384 main_integration : DO J=MYJS2,MYJE2
1385 !
1386 DO I=MYIS1_P1,MYIE1_P1
1387 !-----------------------------------------------------------------------
1388 KOFF=KTE-LMH(I,J)
1389 !
1390 E3(KTE)=Q2(I,KTE,J)*0.5
1391 !
1392 DO K=KTE-1,KOFF+1,-1
1393 E3(K)=MAX((Q2(I,K+1,J)+Q2(I,K,J))*0.5,EPSQ2)
1394 ENDDO
1395 !
1396 DO K=KOFF+1,KTE
1397 Q3(K)=MAX(Q(I,K,J),EPSQ)
1398 W3(K)=MAX(CWM(I,K,J),CLIMIT)
1399 E4(K)=E3(K)
1400 Q4(K)=Q3(K)
1401 W4(K)=W3(K)
1402 ENDDO
1403 !
1404 PETDTK(KTE)=PETDT(I,KTE-1,J)*0.5
1405 !
1406 DO K=KTE-1,KOFF+2,-1
1407 PETDTK(K)=(PETDT(I,K,J)+PETDT(I,K-1,J))*0.5
1408 ENDDO
1409 !
1410 PETDTK(KOFF+1)=PETDT(I,KOFF+1,J)*0.5
1411 !-----------------------------------------------------------------------
1412 HADDT=-ADDT*HBM2(I,J)
1413 !
1414 DO K=KTE,KOFF+1,-1
1415 RR=PETDTK(K)*HADDT
1416 !
1417 IF(RR<0.)THEN
1418 LAP=1
1419 ELSE
1420 LAP=-1
1421 ENDIF
1422 !
1423 LA(K)=LAP
1424 LLAP=K+LAP
1425 !
1426 TOP=.FALSE.
1427 BOT=.FALSE.
1428 !
1429 IF(LLAP>KOFF.AND.LLAP<KTE+1.AND.LAP/=0)THEN
1430 RR=ABS(RR/((AETA1(LLAP)-AETA1(K))*PDTOP &
1431 & +(AETA2(LLAP)-AETA2(K))*PDSL(I,J)))
1432 !
1433 AFR(K)=(((FF4*RR+FF3)*RR+FF2)*RR+FF1)*RR
1434 DQP=(Q3(LLAP)-Q3(K))*RR
1435 DWP=(W3(LLAP)-W3(K))*RR
1436 DEP=(E3(LLAP)-E3(K))*RR
1437 DQL(K)=DQP
1438 DWL(K)=DWP
1439 DEL(K)=DEP
1440 ELSE
1441 TOP=LLAP==KTE+1
1442 BOT=LLAP==KOFF
1443 !
1444 RR=0.
1445 AFR(K)=0.
1446 DQL(K)=0.
1447 DWL(K)=0.
1448 DEL(K)=0.
1449 ENDIF
1450 ENDDO
1451 !-----------------------------------------------------------------------
1452 IF(TOP)THEN
1453 IF(LA(KTE-1)>0)THEN
1454 RFC=(DETA1(KTE-1)*PDTOP+DETA2(KTE-1)*PDSL(I,J)) &
1455 & /(DETA1(KTE )*PDTOP+DETA2(KTE )*PDSL(I,J))
1456 DQL(KTE)=-DQL(KTE+1)*RFC
1457 DWL(KTE)=-DWL(KTE+1)*RFC
1458 DEL(KTE)=-DEL(KTE+1)*RFC
1459 ENDIF
1460 ENDIF
1461 !
1462 IF(BOT)THEN
1463 IF(LA(KOFF+2)<0)THEN
1464 RFC=(DETA1(KOFF+2)*PDTOP+DETA2(KOFF+2)*PDSL(I,J)) &
1465 & /(DETA1(KOFF+1)*PDTOP+DETA2(KOFF+1)*PDSL(I,J))
1466 DQL(KOFF+1)=-DQL(KOFF+2)*RFC
1467 DWL(KOFF+1)=-DWL(KOFF+2)*RFC
1468 DEL(KOFF+1)=-DEL(KOFF+2)*RFC
1469 ENDIF
1470 ENDIF
1471 !
1472 DO K=KOFF+1,KTE
1473 Q4(K)=Q3(K)+DQL(K)
1474 W4(K)=W3(K)+DWL(K)
1475 E4(K)=E3(K)+DEL(K)
1476 ENDDO
1477 !-----------------------------------------------------------------------
1478 !*** ANTI-FILTERING STEP
1479 !-----------------------------------------------------------------------
1480 SUMPQ=0.
1481 SUMNQ=0.
1482 SUMPW=0.
1483 SUMNW=0.
1484 SUMPE=0.
1485 SUMNE=0.
1486 !
1487 !*** ANTI-FILTERING LIMITERS
1488 !
1489 DO 50 K=KTE-1,KOFF+2,-1
1490 !
1491 DETAP=DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J)
1492 !
1493 Q4P=Q4(K)
1494 W4P=W4(K)
1495 E4P=E4(K)
1496 !
1497 LAP=LA(K)
1498 !
1499 IF(LAP.NE.0)THEN
1500 DPDN=(AETA1(K+LAP)-AETA1(K))*PDTOP &
1501 & +(AETA2(K+LAP)-AETA2(K))*PDSL(I,J)
1502 DPUP=(AETA1(K)-AETA1(K-LAP))*PDTOP &
1503 & +(AETA2(K)-AETA2(K-LAP))*PDSL(I,J)
1504 !
1505 AFRP=2.*AFR(K)*DPDN*DPDN/(DPDN+DPUP)
1506 D2PQQ=((Q4(K+LAP)-Q4P)/DPDN &
1507 & -(Q4P-Q4(K-LAP))/DPUP)*AFRP
1508 D2PQW=((W4(K+LAP)-W4P)/DPDN &
1509 & -(W4P-W4(K-LAP))/DPUP)*AFRP
1510 D2PQE=((E4(K+LAP)-E4P)/DPDN &
1511 & -(E4P-E4(K-LAP))/DPUP)*AFRP
1512 ELSE
1513 D2PQQ=0.
1514 D2PQW=0.
1515 D2PQE=0.
1516 ENDIF
1517 !
1518 QP=Q4P-D2PQQ
1519 WP=W4P-D2PQW
1520 EP=E4P-D2PQE
1521 !
1522 Q00=Q3(K)
1523 QP0=Q3(K+LAP)
1524 !
1525 W00=W3(K)
1526 WP0=W3(K+LAP)
1527 !
1528 E00=E3(K)
1529 EP0=E3(K+LAP)
1530 !
1531 IF(LAP/=0)THEN
1532 QP=MAX(QP,MIN(Q00,QP0))
1533 QP=MIN(QP,MAX(Q00,QP0))
1534 WP=MAX(WP,MIN(W00,WP0))
1535 WP=MIN(WP,MAX(W00,WP0))
1536 EP=MAX(EP,MIN(E00,EP0))
1537 EP=MIN(EP,MAX(E00,EP0))
1538 ENDIF
1539 !
1540 DQP=QP-Q00
1541 DWP=WP-W00
1542 DEP=EP-E00
1543 !
1544 DQL(K)=DQP
1545 DWL(K)=DWP
1546 DEL(K)=DEP
1547 !
1548 DQP=DQP*DETAP
1549 DWP=DWP*DETAP
1550 DEP=DEP*DETAP
1551 !
1552 IF(DQP>0.)THEN
1553 SUMPQ=SUMPQ+DQP
1554 ELSE
1555 SUMNQ=SUMNQ+DQP
1556 ENDIF
1557 !
1558 IF(DWP>0.)THEN
1559 SUMPW=SUMPW+DWP
1560 ELSE
1561 SUMNW=SUMNW+DWP
1562 ENDIF
1563 !
1564 IF(DEP>0.)THEN
1565 SUMPE=SUMPE+DEP
1566 ELSE
1567 SUMNE=SUMNE+DEP
1568 ENDIF
1569 !
1570 50 CONTINUE
1571 !-----------------------------------------------------------------------
1572 DQL(KOFF+1)=0.
1573 DWL(KOFF+1)=0.
1574 DEL(KOFF+1)=0.
1575 !
1576 DQL(KTE)=0.
1577 DWL(KTE)=0.
1578 DEL(KTE)=0.
1579 !-----------------------------------------------------------------------
1580 !*** FIRST MOMENT CONSERVING FACTOR
1581 !-----------------------------------------------------------------------
1582 IF(SUMPQ>1.E-9)THEN
1583 RFACQK=-SUMNQ/SUMPQ
1584 ELSE
1585 RFACQK=1.
1586 ENDIF
1587 !
1588 IF(SUMPW>1.E-9)THEN
1589 RFACWK=-SUMNW/SUMPW
1590 ELSE
1591 RFACWK=1.
1592 ENDIF
1593 !
1594 IF(SUMPE>1.E-9)THEN
1595 RFACEK=-SUMNE/SUMPE
1596 ELSE
1597 RFACEK=1.
1598 ENDIF
1599 !
1600 IF(RFACQK<CONSERVE_MIN.OR.RFACQK>CONSERVE_MAX)RFACQK=1.
1601 IF(RFACWK<CONSERVE_MIN.OR.RFACWK>CONSERVE_MAX)RFACWK=1.
1602 IF(RFACEK<CONSERVE_MIN.OR.RFACEK>CONSERVE_MAX)RFACEK=1.
1603 !-----------------------------------------------------------------------
1604 !*** IMPOSE CONSERVATION ON ANTI-FILTERING
1605 !-----------------------------------------------------------------------
1606 DO K=KTE,KOFF+1,-1
1607 DQP=DQL(K)
1608 IF(DQP>=0.)DQP=DQP*RFACQK
1609 Q(I,K,J)=Q3(K)+DQP
1610 ENDDO
1611 !-----------------------------------------------------------------------
1612 DO K=KTE,KOFF+1,-1
1613 DWP=DWL(K)
1614 IF(DWP>=0.)DWP=DWP*RFACWK
1615 CWM(I,K,J)=W3(K)+DWP
1616 ENDDO
1617 !-----------------------------------------------------------------------
1618 DO K=KTE,KOFF+1,-1
1619 DEP=DEL(K)
1620 IF(DEP>=0.)DEP=DEP*RFACEK
1621 E3(K)=E3(K)+DEP
1622 ENDDO
1623 !
1624 HBM2IJ=HBM2(I,J)
1625 Q2(I,KTE,J)=MAX(E3(KTE)+E3(KTE)-EPSQ2,EPSQ2)*HBM2IJ &
1626 & +Q2(I,KTE,J)*(1.-HBM2IJ)
1627 DO K=KTE-1,KOFF+2,-1
1628 Q2(I,K,J)=MAX(E3(K)+E3(K)-Q2(I,K+1,J),EPSQ2)*HBM2IJ &
1629 & +Q2(I,K,J)*(1.-HBM2IJ)
1630 ENDDO
1631 !-----------------------------------------------------------------------
1632 !-----------------------------------------------------------------------
1633 ENDDO
1634 !
1635 ENDDO main_integration
1636 !-----------------------------------------------------------------------
1637 !-----------------------------------------------------------------------
1638 END SUBROUTINE VAD2
1639 !-----------------------------------------------------------------------
1640 !
1641 !***********************************************************************
1642 SUBROUTINE HAD2( &
1643 #if defined(DM_PARALLEL)
1644 & domdesc , &
1645 #endif
1646 & NTSD,DT,IDTAD,DX,DY &
1647 & ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP &
1648 & ,HTM,HBM2,HBM3,LMH &
1649 & ,Q,Q2,CWM,U,V,Z,HYDRO &
1650 & ,N_IUP_H,N_IUP_V &
1651 & ,N_IUP_ADH,N_IUP_ADV &
1652 & ,IUP_H,IUP_V,IUP_ADH,IUP_ADV &
1653 & ,IHE,IHW,IVE,IVW,INDX3_WRK &
1654 & ,IDS,IDE,JDS,JDE,KDS,KDE &
1655 & ,IMS,IME,JMS,JME,KMS,KME &
1656 & ,ITS,ITE,JTS,JTE,KTS,KTE)
1657 !***********************************************************************
1658 !$$$ SUBPROGRAM DOCUMENTATION BLOCK
1659 ! . . .
1660 ! SUBPROGRAM: HAD2 HORIZONTAL ADVECTION OF H2O AND TKE
1661 ! PRGRMMR: JANJIC ORG: W/NP22 DATE: 96-07-19
1662 !
1663 ! ABSTRACT:
1664 ! HAD2 CALCULATES THE CONTRIBUTION OF THE HORIZONTAL ADVECTION
1665 ! TO THE TENDENCIES OF WATER SUBSTANCE AND TKE AND THEN
1666 ! UPDATES THOSE VARIABLES. AN ANTI-FILTERING TECHNIQUE IS USED.
1667 !
1668 ! PROGRAM HISTORY LOG:
1669 ! 96-07-19 JANJIC - ORIGINATOR
1670 ! 98-11-02 BLACK - MODIFIED FOR DISTRIBUTED MEMORY
1671 ! 99-03-17 TUCCILLO - INCORPORATED MPI_ALLREDUCE FOR GLOBAL SUM
1672 ! 02-02-06 BLACK - CONVERTED TO WRF FORMAT
1673 ! 02-09-06 WOLFE - MORE CONVERSION TO GLOBAL INDEXING
1674 ! 03-05-23 JANJIC - ADDED SLOPE FACTOR
1675 ! 04-11-23 BLACK - THREADED
1676 !
1677 ! USAGE: CALL HAD2 FROM SUBROUTINE SOLVE_NMM
1678 ! INPUT ARGUMENT LIST:
1679 !
1680 ! OUTPUT ARGUMENT LIST
1681 !
1682 ! OUTPUT FILES:
1683 ! NONE
1684 ! SUBPROGRAMS CALLED:
1685 !
1686 ! UNIQUE: NONE
1687 !
1688 ! LIBRARY: NONE
1689 !
1690 ! ATTRIBUTES:
1691 ! LANGUAGE: FORTRAN 90
1692 ! MACHINE : IBM SP
1693 !$$$
1694 !***********************************************************************
1695 !-----------------------------------------------------------------------
1696 !
1697 IMPLICIT NONE
1698 !
1699 !-----------------------------------------------------------------------
1700 !
1701 INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
1702 & ,IMS,IME,JMS,JME,KMS,KME &
1703 & ,ITS,ITE,JTS,JTE,KTS,KTE
1704 !
1705 INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
1706 INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: N_IUP_H,N_IUP_V &
1707 & ,N_IUP_ADH,N_IUP_ADV
1708 INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: IUP_H,IUP_V &
1709 & ,IUP_ADH,IUP_ADV
1710 !-----------------------------------------------------------------------
1711 !!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1712 ! NMM_MAX_DIM is set in configure.wrf and must agree with the value of
1713 ! dimspec q in Registry/Registry.
1714 !!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1715 !-----------------------------------------------------------------------
1716 INTEGER,DIMENSION(-3:3,NMM_MAX_DIM,0:6),INTENT(IN) :: INDX3_WRK
1717 !
1718 INTEGER,INTENT(IN) :: IDTAD,NTSD
1719 !
1720 INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: LMH
1721 !
1722 REAL,INTENT(IN) :: DT,DY,PDTOP
1723 !
1724 REAL,DIMENSION(KMS:KME),INTENT(IN) :: AETA1,AETA2,DETA1,DETA2
1725 !
1726 REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DX,HBM2,HBM3,PDSL
1727 !
1728 REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: HTM,U,V,Z
1729 !
1730 REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: CWM,Q,Q2
1731 !
1732 LOGICAL,INTENT(IN) :: HYDRO
1733 !
1734 !-----------------------------------------------------------------------
1735 !
1736 !*** LOCAL VARIABLES
1737 !
1738 REAL,PARAMETER :: FF1=0.530
1739 !
1740 #ifdef DM_PARALLEL
1741 INTEGER :: DOMDESC
1742 #endif
1743 !
1744 #if defined(BIT_FOR_BIT) && defined(DM_PARALLEL)
1745 LOGICAL,EXTERNAL :: WRF_DM_ON_MONITOR
1746 INTEGER :: N
1747 REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME,6) :: XSUMS_L
1748 REAL,DIMENSION(IDS:IDE,KDS:KDE,JDS:JDE,6) :: XSUMS_G
1749 #endif
1750 !
1751 LOGICAL :: BOT,TOP
1752 !
1753 INTEGER :: I,IRECV,J,JFP,JFQ,K,KOFF,LAP,LLAP,MPI_COMM_COMP
1754 !
1755 INTEGER,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: IFPA,IFPF &
1756 & ,IFQA,IFQF &
1757 & ,JFPA,JFPF &
1758 & ,JFQA,JFQF
1759 !
1760 REAL :: ADDT,AFRP,CRIT,D2PQE,D2PQQ,D2PQW,DEP,DESTIJ,DQP,DQSTIJ &
1761 & ,DVOLP,DWP,DWSTIJ,DZA,DZB,E00,E0Q,E1X,E2IJ,E4P,ENH,EP,EP0 &
1762 & ,ESTIJ,FPQ,HAFP,HAFQ,HBM2IJ,HM,HTMIKJ,PP,PPQ00,Q00,Q0Q &
1763 & ,Q1IJ,Q4P,QP,QP0,QSTIJ,RDY,RFACEK,RFACQK,RFACWK,RFC &
1764 & ,RFEIJ,RFQIJ,RFWIJ,RR,SLOPAC,SPP,SQP,SSA,SSB,SUMNE,SUMNQ &
1765 & ,SUMNW,SUMPE,SUMPQ,SUMPW,TTA,TTB,W00,W0Q,W1IJ,W4P,WP,WP0 &
1766 & ,WSTIJ
1767 !
1768 DOUBLE PRECISION,DIMENSION(6,KTE-KTS+1) :: GSUMS,XSUMS
1769 !
1770 REAL,DIMENSION(KTS:KTE) :: AFR,DEL,DQL,DWL,E3,E4 &
1771 & ,RFACE,RFACQ,RFACW,Q3,Q4,W3,W4
1772 !
1773 REAL,DIMENSION(IMS:IME,JMS:JME) :: DARE,EMH
1774 !
1775 REAL,DIMENSION(ITS-5:ITE+5,KTS:KTE,JTS-5:JTE+5) :: AFP,AFQ,DEST &
1776 & ,DQST,DVOL,DWST &
1777 & ,E1,E2,Q1,W1
1778 integer :: nunit,ier
1779 save nunit
1780 !***********************************************************************
1781 !-----------------------------------------------------------------------
1782 !
1783 RDY=1./DY
1784 SLOPAC=SLOPHT*SQRT(2.)*0.5*50.
1785 CRIT=SLOPAC*REAL(IDTAD)*DT*RDY*1000.
1786 !
1787 ADDT=REAL(IDTAD)*DT
1788 ENH=ADDT/(08.*DY)
1789 !
1790 !-----------------------------------------------------------------------
1791 !$omp parallel do &
1792 !$omp& private(i,j)
1793 DO J=MYJS_P3,MYJE_P3
1794 DO I=MYIS_P2,MYIE_P2
1795 EMH (I,J)=ADDT/(08.*DX(I,J))
1796 DARE(I,J)=HBM3(I,J)*DX(I,J)*DY
1797 E1(I,KTE,J)=MAX(Q2(I,KTE,J)*0.5,EPSQ2)
1798 E2(I,KTE,J)=E1(I,KTE,J)
1799 ENDDO
1800 ENDDO
1801 !-----------------------------------------------------------------------
1802 !
1803 !$omp parallel do &
1804 !$omp& private(e1x,htmikj,i,j,k)
1805 DO J=MYJS_P3,MYJE_P3
1806 DO K=KTS,KTE
1807 DO I=MYIS_P2,MYIE_P2
1808 DVOL(I,K,J)=DARE(I,J)*(DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J))
1809 HTMIKJ=HTM(I,K,J)
1810 Q (I,K,J)=MAX(Q (I,K,J),EPSQ)*HTMIKJ
1811 CWM(I,K,J)=MAX(CWM(I,K,J),CLIMIT)*HTMIKJ
1812 Q1 (I,K,J)=Q (I,K,J)
1813 W1 (I,K,J)=CWM(I,K,J)
1814 ENDDO
1815 ENDDO
1816 !
1817 DO K=KTE-1,KTS,-1
1818 DO I=MYIS_P2,MYIE_P2
1819 E1X=(Q2(I,K+1,J)+Q2(I,K,J))*0.5
1820 E1(I,K,J)=MAX(E1X,EPSQ2)
1821 E2(I,K,J)=E1(I,K,J)
1822 ENDDO
1823 ENDDO
1824 !
1825 ENDDO
1826 !-----------------------------------------------------------------------
1827 !$omp parallel do &
1828 !$omp& private(dza,dzb,fpq,i,j,jfp,jfq,k,pp,qp,ssa,ssb,spp,sqp,tta,ttb)
1829 DO J=MYJS2_P1,MYJE2_P1
1830 DO K=KTS,KTE
1831 DO I=MYIS1_P1,MYIE1_P1
1832 !
1833 TTA=(U(I,K,J-1)+U(I+IHW(J),K,J)+U(I+IHE(J),K,J)+U(I,K,J+1)) &
1834 & *EMH(I,J)*HBM2(I,J)
1835 TTB=(V(I,K,J-1)+V(I+IHW(J),K,J)+V(I+IHE(J),K,J)+V(I,K,J+1)) &
1836 & *ENH*HBM2(I,J)
1837 !
1838 SPP=-TTA-TTB
1839 SQP= TTA-TTB
1840 !
1841 IF(SPP<0.)THEN
1842 JFP=-1
1843 ELSE
1844 JFP=1
1845 ENDIF
1846 IF(SQP<0.)THEN
1847 JFQ=-1
1848 ELSE
1849 JFQ=1
1850 ENDIF
1851 !
1852 IFPA(I,K,J)=IHE(J)+I+( JFP-1)/2
1853 IFQA(I,K,J)=IHE(J)+I+(-JFQ-1)/2
1854 !
1855 JFPA(I,K,J)=J+JFP
1856 JFQA(I,K,J)=J+JFQ
1857 !
1858 IFPF(I,K,J)=IHE(J)+I+(-JFP-1)/2
1859 IFQF(I,K,J)=IHE(J)+I+( JFQ-1)/2
1860 !
1861 JFPF(I,K,J)=J-JFP
1862 JFQF(I,K,J)=J-JFQ
1863 !
1864 !-----------------------------------------------------------------------
1865 IF(.NOT.HYDRO)THEN ! z currently not available for hydro=.true.
1866 DZA=(Z(IFPA(I,K,J),K,JFPA(I,K,J))-Z(I,K,J))*RDY
1867 DZB=(Z(IFQA(I,K,J),K,JFQA(I,K,J))-Z(I,K,J))*RDY
1868 !
1869 IF(ABS(DZA)>SLOPAC)THEN
1870 SSA=DZA*SPP
1871 IF(SSA>CRIT)THEN
1872 SPP=0. !spp*.1
1873 ENDIF
1874 ENDIF
1875 !
1876 IF(ABS(DZB)>SLOPAC)THEN
1877 SSB=DZB*SQP
1878 IF(SSB>CRIT)THEN
1879 SQP=0. !sqp*.1
1880 ENDIF
1881 ENDIF
1882 !
1883 ENDIF
1884 !-----------------------------------------------------------------------
1885 SPP=SPP*HTM(IFPA(I,K,J),K,JFPA(I,K,J))
1886 SQP=SQP*HTM(IFQA(I,K,J),K,JFQA(I,K,J))
1887 FPQ=SPP*SQP*HTM(I,K,J-2)*HTM(I-1,K,J) &
1888 & *HTM(I+1,K,J)*HTM(I,K,J+2)*0.25
1889 PP=ABS(SPP)
1890 QP=ABS(SQP)
1891 !
1892 AFP(I,K,J)=(((FF4*PP+FF3)*PP+FF2)*PP+FF1)*PP
1893 AFQ(I,K,J)=(((FF4*QP+FF3)*QP+FF2)*QP+FF1)*QP
1894 !
1895 Q1(I,K,J)=(Q (IFPA(I,K,J),K,JFPA(I,K,J))-Q (I,K,J))*PP &
1896 & +(Q (IFQA(I,K,J),K,JFQA(I,K,J))-Q (I,K,J))*QP &
1897 & +(Q (I,K,J-2)+Q (I,K,J+2) &
1898 & -Q (I-1,K,J)-Q (I+1,K,J))*FPQ &
1899 & +Q(I,K,J)
1900 !
1901 W1(I,K,J)=(CWM(IFPA(I,K,J),K,JFPA(I,K,J))-CWM(I,K,J))*PP &
1902 & +(CWM(IFQA(I,K,J),K,JFQA(I,K,J))-CWM(I,K,J))*QP &
1903 & +(CWM(I,K,J-2)+CWM(I,K,J+2) &
1904 & -CWM(I-1,K,J)-CWM(I+1,K,J))*FPQ &
1905 & +CWM(I,K,J)
1906 !
1907 E2(I,K,J)=(E1 (IFPA(I,K,J),K,JFPA(I,K,J))-E1 (I,K,J))*PP &
1908 & +(E1 (IFQA(I,K,J),K,JFQA(I,K,J))-E1 (I,K,J))*QP &
1909 & +(E1 (I,K,J-2)+E1 (I,K,J+2) &
1910 & -E1 (I-1,K,J)-E1 (I+1,K,J))*FPQ &
1911 & +E1(I,K,J)
1912 !
1913 ENDDO
1914 ENDDO
1915 ENDDO
1916 !
1917 !-----------------------------------------------------------------------
1918 !*** ANTI-FILTERING STEP
1919 !-----------------------------------------------------------------------
1920 !
1921 DO K=KTS,KTE
1922 XSUMS(1,K)=0.
1923 XSUMS(2,K)=0.
1924 XSUMS(3,K)=0.
1925 XSUMS(4,K)=0.
1926 XSUMS(5,K)=0.
1927 XSUMS(6,K)=0.
1928 ENDDO
1929 !-----------------------------------------------------------------------
1930 !
1931 !*** ANTI-FILTERING LIMITERS
1932 !
1933 !-----------------------------------------------------------------------
1934 #if defined(BIT_FOR_BIT) && defined(DM_PARALLEL)
1935 DO N=1,6
1936 !
1937 !$omp parallel do &
1938 !$omp& private(i,j,k)
1939 DO J=JMS,JME
1940 DO K=KMS,KME
1941 DO I=IMS,IME
1942 XSUMS_L(I,K,J,N)=0.
1943 ENDDO
1944 ENDDO
1945 ENDDO
1946 !
1947 !$omp parallel do &
1948 !$omp& private(i,j,k)
1949 DO J=JDS,JDE
1950 DO K=KDS,KDE
1951 DO I=IDS,IDE
1952 XSUMS_G(I,K,J,N)=0.
1953 ENDDO
1954 ENDDO
1955 ENDDO
1956 !
1957 ENDDO
1958 !
1959 #endif
1960 !-----------------------------------------------------------------------
1961 DO 150 J=MYJS2,MYJE2
1962 DO 150 K=KTS,KTE
1963 DO 150 I=MYIS1,MYIE1
1964 !
1965 DVOLP=DVOL(I,K,J)
1966 Q1IJ =Q1(I,K,J)
1967 W1IJ =W1(I,K,J)
1968 E2IJ =E2(I,K,J)
1969 !
1970 HAFP=HTM(IFPF(I,K,J),K,JFPF(I,K,J))*AFP(I,K,J)
1971 HAFQ=HTM(IFQF(I,K,J),K,JFQF(I,K,J))*AFQ(I,K,J)
1972 !
1973 D2PQQ=(Q1(IFPA(I,K,J),K,JFPA(I,K,J))-Q1IJ &
1974 & -Q1IJ+Q1(IFPF(I,K,J),K,JFPF(I,K,J))) &
1975 & *HAFP &
1976 & +(Q1(IFQA(I,K,J),K,JFQA(I,K,J))-Q1IJ &
1977 & -Q1IJ+Q1(IFQF(I,K,J),K,JFQF(I,K,J))) &
1978 & *HAFQ
1979 !
1980 D2PQW=(W1(IFPA(I,K,J),K,JFPA(I,K,J))-W1IJ &
1981 & -W1IJ+W1(IFPF(I,K,J),K,JFPF(I,K,J))) &
1982 & *HAFP &
1983 & +(W1(IFQA(I,K,J),K,JFQA(I,K,J))-W1IJ &
1984 & -W1IJ+W1(IFQF(I,K,J),K,JFQF(I,K,J))) &
1985 & *HAFQ
1986 !
1987 D2PQE=(E2(IFPA(I,K,J),K,JFPA(I,K,J))-E2IJ &
1988 & -E2IJ+E2(IFPF(I,K,J),K,JFPF(I,K,J))) &
1989 & *HAFP &
1990 & +(E2(IFQA(I,K,J),K,JFQA(I,K,J))-E2IJ &
1991 & -E2IJ+E2(IFQF(I,K,J),K,JFQF(I,K,J))) &
1992 & *HAFQ
1993 !
1994 QSTIJ=Q1IJ-D2PQQ
1995 WSTIJ=W1IJ-D2PQW
1996 ESTIJ=E2IJ-D2PQE
1997 !
1998 Q00=Q (I ,K ,J)
1999 QP0=Q (IFPA(I,K,J),K,JFPA(I,K,J))
2000 Q0Q=Q (IFQA(I,K,J),K,JFQA(I,K,J))
2001 !
2002 W00=CWM(I ,K ,J)
2003 WP0=CWM(IFPA(I,K,J),K,JFPA(I,K,J))
2004 W0Q=CWM(IFQA(I,K,J),K,JFQA(I,K,J))
2005 !
2006 E00=E1 (I ,K ,J)
2007 EP0=E1 (IFPA(I,K,J),K,JFPA(I,K,J))
2008 E0Q=E1 (IFQA(I,K,J),K,JFQA(I,K,J))
2009 !
2010 QSTIJ=MAX(QSTIJ,MIN(Q00,QP0,Q0Q))
2011 QSTIJ=MIN(QSTIJ,MAX(Q00,QP0,Q0Q))
2012 WSTIJ=MAX(WSTIJ,MIN(W00,WP0,W0Q))
2013 WSTIJ=MIN(WSTIJ,MAX(W00,WP0,W0Q))
2014 ESTIJ=MAX(ESTIJ,MIN(E00,EP0,E0Q))
2015 ESTIJ=MIN(ESTIJ,MAX(E00,EP0,E0Q))
2016 !
2017 DQSTIJ=QSTIJ-Q(I,K,J)
2018 DWSTIJ=WSTIJ-CWM(I,K,J)
2019 DESTIJ=ESTIJ-E1(I,K,J)
2020 !
2021 DQST(I,K,J)=DQSTIJ
2022 DWST(I,K,J)=DWSTIJ
2023 DEST(I,K,J)=DESTIJ
2024 !
2025 DQSTIJ=DQSTIJ*DVOLP
2026 DWSTIJ=DWSTIJ*DVOLP
2027 DESTIJ=DESTIJ*DVOLP
2028 !
2029 #if defined(BIT_FOR_BIT) && defined(DM_PARALLEL)
2030 DO N=1,6
2031 XSUMS_L(I,K,J,N)=0.
2032 ENDDO
2033 !
2034 IF(DQSTIJ>0.)THEN
2035 XSUMS_L(I,K,J,1)=DQSTIJ
2036 ELSE
2037 XSUMS_L(I,K,J,2)=DQSTIJ
2038 ENDIF
2039 !
2040 IF(DWSTIJ>0.)THEN
2041 XSUMS_L(I,K,J,3)=DWSTIJ
2042 ELSE
2043 XSUMS_L(I,K,J,4)=DWSTIJ
2044 ENDIF
2045 !
2046 IF(DESTIJ>0.)THEN
2047 XSUMS_L(I,K,J,5)=DESTIJ
2048 ELSE
2049 XSUMS_L(I,K,J,6)=DESTIJ
2050 ENDIF
2051 #else
2052 IF(DQSTIJ>0.)THEN
2053 XSUMS(1,K)=XSUMS(1,K)+DQSTIJ
2054 ELSE
2055 XSUMS(2,K)=XSUMS(2,K)+DQSTIJ
2056 ENDIF
2057 !
2058 IF(DWSTIJ>0.)THEN
2059 XSUMS(3,K)=XSUMS(3,K)+DWSTIJ
2060 ELSE
2061 XSUMS(4,K)=XSUMS(4,K)+DWSTIJ
2062 ENDIF
2063 !
2064 IF(DESTIJ>0.)THEN
2065 XSUMS(5,K)=XSUMS(5,K)+DESTIJ
2066 ELSE
2067 XSUMS(6,K)=XSUMS(6,K)+DESTIJ
2068 ENDIF
2069 #endif
2070 !
2071 150 CONTINUE
2072 !
2073 !-----------------------------------------------------------------------
2074 #if defined(BIT_FOR_BIT) && defined(DM_PARALLEL)
2075 DO N=1,6
2076 CALL WRF_PATCH_TO_GLOBAL_REAL( XSUMS_L(IMS,KMS,JMS,N) &
2077 &, XSUMS_G(1,1,1,N),DOMDESC &
2078 &, 'xyz','xzy' &
2079 &, IDS,IDE,KDS,KDE,JDS,JDE &
2080 &, IMS,IME,KMS,KME,JMS,JME &
2081 &, ITS,ITE,KTS,KTE,JTS,JTE )
2082 ENDDO
2083 !
2084 GSUMS=0.
2085 !
2086 IF(WRF_DM_ON_MONITOR())THEN
2087 DO N=1,6
2088 !$omp parallel do &
2089 !$omp& private(i,j,k)
2090 DO J=JDS,JDE
2091 DO K=KDS,KDE
2092 DO I=IDS,IDE
2093 GSUMS(N,K)=GSUMS(N,K)+XSUMS_G(I,K,J,N)
2094 ENDDO
2095 ENDDO
2096 ENDDO
2097 ENDDO
2098 ENDIF
2099
2100 CALL WRF_DM_BCAST_BYTES(GSUMS,2*RWORDSIZE*6*(KDE-KDS+1) )
2101
2102 #else
2103 !-----------------------------------------------------------------------
2104 !
2105 !-----------------------------------------------------------------------
2106 !*** GLOBAL REDUCTION
2107 !-----------------------------------------------------------------------
2108 !
2109 # ifdef DM_PARALLEL
2110 CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP)
2111 CALL MPI_ALLREDUCE(XSUMS,GSUMS,6*(KTE-KTS+1) &
2112 & ,MPI_DOUBLE_PRECISION,MPI_SUM &
2113 & ,MPI_COMM_COMP,IRECV)
2114 # else
2115 GSUMS=XSUMS
2116 # endif
2117 #endif
2118 !
2119 !-----------------------------------------------------------------------
2120 !*** END OF GLOBAL REDUCTION
2121 !-----------------------------------------------------------------------
2122 !
2123 ! if(mype==0)then
2124 ! if(ntsd==0)then
2125 !! call int_get_fresh_handle(nunit)
2126 !! close(nunit)
2127 ! nunit=56
2128 ! open(unit=nunit,file='gsums',form='unformatted',iostat=ier)
2129 ! endif
2130 ! endif
2131 DO K=KTS,KTE
2132 ! if(mype==0)then
2133 ! write(nunit)(gsums(i,k),i=1,6)
2134 ! endif
2135 !
2136 !-----------------------------------------------------------------------
2137 SUMPQ=GSUMS(1,K)
2138 SUMNQ=GSUMS(2,K)
2139 SUMPW=GSUMS(3,K)
2140 SUMNW=GSUMS(4,K)
2141 SUMPE=GSUMS(5,K)
2142 SUMNE=GSUMS(6,K)
2143 !
2144 !-----------------------------------------------------------------------
2145 !*** FIRST MOMENT CONSERVING FACTOR
2146 !-----------------------------------------------------------------------
2147 !
2148 IF(SUMPQ>1.)THEN
2149 RFACQK=-SUMNQ/SUMPQ
2150 ELSE
2151 RFACQK=1.
2152 ENDIF
2153 !
2154 IF(SUMPW>1.)THEN
2155 RFACWK=-SUMNW/SUMPW
2156 ELSE
2157 RFACWK=1.
2158 ENDIF
2159 !
2160 IF(SUMPE>1.)THEN
2161 RFACEK=-SUMNE/SUMPE
2162 ELSE
2163 RFACEK=1.
2164 ENDIF
2165 !
2166 IF(RFACQK<CONSERVE_MIN.OR.RFACQK>CONSERVE_MAX)RFACQK=1.
2167 IF(RFACWK<CONSERVE_MIN.OR.RFACWK>CONSERVE_MAX)RFACWK=1.
2168 IF(RFACEK<CONSERVE_MIN.OR.RFACEK>CONSERVE_MAX)RFACEK=1.
2169 !
2170 RFACQ(K)=RFACQK
2171 RFACW(K)=RFACWK
2172 RFACE(K)=RFACEK
2173 !
2174 ENDDO
2175 ! if(mype==0.and.ntsd==181)close(nunit)
2176 !
2177 !-----------------------------------------------------------------------
2178 !*** IMPOSE CONSERVATION ON ANTI-FILTERING
2179 !-----------------------------------------------------------------------
2180 !$omp parallel do &
2181 !$omp& private(dqstij,i,j,k,rfacqk,rfqij)
2182 DO J=MYJS2,MYJE2
2183 DO K=KTS,KTE
2184 RFACQK=RFACQ(K)
2185 IF(RFACQK<1.)THEN
2186 DO I=MYIS1,MYIE1
2187 DQSTIJ=DQST(I,K,J)
2188 RFQIJ=HBM2(I,J)*(RFACQK-1.)+1.
2189 IF(DQSTIJ>=0.)DQSTIJ=DQSTIJ*RFQIJ
2190 Q(I,K,J)=Q(I,K,J)+DQSTIJ
2191 ENDDO
2192 ELSE
2193 DO I=MYIS1,MYIE1
2194 DQSTIJ=DQST(I,K,J)
2195 RFQIJ=HBM2(I,J)*(RFACQK-1.)+1.
2196 IF(DQSTIJ<0.)DQSTIJ=DQSTIJ/RFQIJ
2197 Q(I,K,J)=Q(I,K,J)+DQSTIJ
2198 ENDDO
2199 ENDIF
2200 ENDDO
2201 ENDDO
2202 !-----------------------------------------------------------------------
2203 !$omp parallel do &
2204 !$omp& private(dwstij,i,j,k,rfacwk,rfwij)
2205 DO J=MYJS2,MYJE2
2206 DO K=KTS,KTE
2207 RFACWK=RFACW(K)
2208 IF(RFACWK<1.)THEN
2209 DO I=MYIS1,MYIE1
2210 DWSTIJ=DWST(I,K,J)
2211 RFWIJ=HBM2(I,J)*(RFACWK-1.)+1.
2212 IF(DWSTIJ>=0.)DWSTIJ=DWSTIJ*RFWIJ
2213 CWM(I,K,J)=CWM(I,K,J)+DWSTIJ
2214 ENDDO
2215 ELSE
2216 DO I=MYIS1,MYIE1
2217 DWSTIJ=DWST(I,K,J)
2218 RFWIJ=HBM2(I,J)*(RFACWK-1.)+1.
2219 IF(DWSTIJ<0.)DWSTIJ=DWSTIJ/RFWIJ
2220 CWM(I,K,J)=CWM(I,K,J)+DWSTIJ
2221 ENDDO
2222 ENDIF
2223 ENDDO
2224 ENDDO
2225 !-----------------------------------------------------------------------
2226 !$omp parallel do &
2227 !$omp& private(destij,i,j,k,rfacek,rfeij)
2228 DO J=MYJS2,MYJE2
2229 DO K=KTS,KTE
2230 RFACEK=RFACE(K)
2231 IF(RFACEK<1.)THEN
2232 DO I=MYIS1,MYIE1
2233 DESTIJ=DEST(I,K,J)
2234 RFEIJ=HBM2(I,J)*(RFACEK-1.)+1.
2235 IF(DESTIJ>=0.)DESTIJ=DESTIJ*RFEIJ
2236 E1(I,K,J)=E1(I,K,J)+DESTIJ
2237 ENDDO
2238 ELSE
2239 DO I=MYIS1,MYIE1
2240 DESTIJ=DEST(I,K,J)
2241 RFEIJ=HBM2(I,J)*(RFACEK-1.)+1.
2242 IF(DESTIJ<0.)DESTIJ=DESTIJ/RFEIJ
2243 E1(I,K,J)=E1(I,K,J)+DESTIJ
2244 ENDDO
2245 ENDIF
2246 ENDDO
2247 ENDDO
2248 !-----------------------------------------------------------------------
2249 !$omp parallel do &
2250 !$omp& private(i,j,k)
2251 DO J=MYJS,MYJE
2252 DO K=KTS,KTE
2253 DO I=MYIS,MYIE
2254 Q (I,K,J)=MAX(Q (I,K,J),EPSQ)*HTM(I,K,J)
2255 CWM(I,K,J)=MAX(CWM(I,K,J),CLIMIT)*HTM(I,K,J)
2256 ENDDO
2257 ENDDO
2258 ENDDO
2259 !
2260 !$omp parallel do &
2261 !$omp& private(i,j)
2262 DO J=MYJS,MYJE
2263 DO I=MYIS,MYIE
2264 Q2(I,KTE,J)=MAX(E1(I,KTE,J)+E1(I,KTE,J)-EPSQ2,EPSQ2) &
2265 & *HTM(I,KTE,J)
2266 ENDDO
2267 ENDDO
2268 !
2269 !$omp parallel do &
2270 !$omp& private(i,j,k,koff)
2271 DO J=MYJS,MYJE
2272 DO K=KTE-1,KTS+1,-1
2273 DO I=MYIS,MYIE
2274 KOFF=KTE-LMH(I,J)
2275 IF(K>KOFF+1)THEN
2276 Q2(I,K,J)=MAX(E1(I,K,J)+E1(I,K,J)-Q2(I,K+1,J),EPSQ2) &
2277 & *HTM(I,K,J)
2278 ELSE
2279 Q2(I,K,J)=Q2(I,K+1,J)
2280 ENDIF
2281 ENDDO
2282 ENDDO
2283 ENDDO
2284 !-----------------------------------------------------------------------
2285 END SUBROUTINE HAD2
2286 !-----------------------------------------------------------------------
2287 !***********************************************************************
2288 SUBROUTINE VAD2_DRY(NTSD,DT,IDTAD,DX,DY &
2289 & ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP &
2290 & ,HBM2,LMH &
2291 & ,Q2,PETDT &
2292 & ,N_IUP_H,N_IUP_V &
2293 & ,N_IUP_ADH,N_IUP_ADV &
2294 & ,IUP_H,IUP_V,IUP_ADH,IUP_ADV &
2295 & ,IHE,IHW,IVE,IVW,INDX3_WRK &
2296 & ,IDS,IDE,JDS,JDE,KDS,KDE &
2297 & ,IMS,IME,JMS,JME,KMS,KME &
2298 & ,ITS,ITE,JTS,JTE,KTS,KTE)
2299 !***********************************************************************
2300 !$$$ SUBPROGRAM DOCUMENTATION BLOCK
2301 ! . . .
2302 ! SUBPROGRAM: VAD2_DRY VERTICAL ADVECTION OF TKE
2303 ! PRGRMMR: JANJIC ORG: W/NP22 DATE: 96-07-19
2304 !
2305 ! ABSTRACT:
2306 ! VAD2 CALCULATES THE CONTRIBUTION OF THE HORIZONTAL AND VERTICAL
2307 ! ADVECTION TO THE TENDENCY OF TKE AND THEN UPDATES IT.
2308 ! AN ANTI-FILTERING TECHNIQUE IS USED.
2309 !
2310 ! PROGRAM HISTORY LOG:
2311 ! 96-07-19 JANJIC - ORIGINATOR
2312 ! 98-11-02 BLACK - MODIFIED FOR DISTRIBUTED MEMORY
2313 ! 99-03-17 TUCCILLO - INCORPORATED MPI_ALLREDUCE FOR GLOBAL SUM
2314 ! 02-02-06 BLACK - CONVERTED TO WRF FORMAT
2315 ! 02-09-06 WOLFE - MORE CONVERSION TO GLOBAL INDEXING
2316 ! 04-11-23 BLACK - THREADED
2317 !
2318 ! USAGE: CALL VAD2_DRY FROM SUBROUTINE DIGITAL_FILTER
2319 ! INPUT ARGUMENT LIST:
2320 !
2321 ! OUTPUT ARGUMENT LIST
2322 !
2323 ! OUTPUT FILES:
2324 ! NONE
2325 ! SUBPROGRAMS CALLED:
2326 !
2327 ! UNIQUE: NONE
2328 !
2329 ! LIBRARY: NONE
2330 !
2331 ! ATTRIBUTES:
2332 ! LANGUAGE: FORTRAN 90
2333 ! MACHINE : IBM SP
2334 !$$$
2335 !***********************************************************************
2336 !-----------------------------------------------------------------------
2337 !
2338 IMPLICIT NONE
2339 !
2340 !-----------------------------------------------------------------------
2341 !
2342 INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
2343 & ,IMS,IME,JMS,JME,KMS,KME &
2344 & ,ITS,ITE,JTS,JTE,KTS,KTE
2345 !
2346 INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
2347 INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: N_IUP_H,N_IUP_V &
2348 & ,N_IUP_ADH,N_IUP_ADV
2349 INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: IUP_H,IUP_V &
2350 & ,IUP_ADH,IUP_ADV
2351 ! NMM_MAX_DIM is set in configure.wrf and must agree with
2352 ! the value of dimspec q in the Registry/Registry
2353 INTEGER,DIMENSION(-3:3,NMM_MAX_DIM,0:6),INTENT(IN) :: INDX3_WRK
2354 !
2355 INTEGER,INTENT(IN) :: IDTAD,NTSD
2356 !
2357 INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: LMH
2358 !
2359 REAL,INTENT(IN) :: DT,DY,PDTOP
2360 !
2361 REAL,DIMENSION(KMS:KME),INTENT(IN) :: AETA1,AETA2,DETA1,DETA2
2362 !
2363 REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DX,HBM2,PDSL
2364 !
2365 REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: PETDT
2366 !
2367 REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: Q2
2368 !
2369 !-----------------------------------------------------------------------
2370 !
2371 !*** LOCAL VARIABLES
2372 !
2373 REAL,PARAMETER :: FF1=0.525
2374 !
2375 LOGICAL :: BOT,TOP
2376 !
2377 INTEGER :: I,IRECV,J,JFP,JFQ,K,KOFF,LAP,LLAP
2378 !
2379 INTEGER,DIMENSION(KTS:KTE) :: LA
2380 !
2381 REAL :: ADDT,AFRP,D2PQE,DEP,DETAP,DPDN,DPUP,DQP &
2382 & ,DWP,E00,E4P,EP,EP0,HADDT,HBM2IJ &
2383 & ,RFACEK,RFC,RR,SUMNE,SUMPE
2384 !
2385 REAL,DIMENSION(KTS:KTE) :: AFR,DEL,E3,E4,PETDTK,RFACE
2386 !
2387 !***********************************************************************
2388 !-----------------------------------------------------------------------
2389 !
2390 ADDT=REAL(IDTAD)*DT
2391 !
2392 !-----------------------------------------------------------------------
2393 !
2394 !$omp parallel do &
2395 !$omp& private(afr,afrp,bot,d2pqe,del,dep,detap,dpdn,dpup,e00,e3 &
2396 !$omp& ,e4,e4p,ep,ep0,hbm2ij,i,j,k,koff,la,lap,llap,petdtk &
2397 !$omp& ,rfacek,rfc,rr,sumne,sumpe,top)
2398 main_integration : DO J=MYJS2,MYJE2
2399 !
2400 DO I=MYIS1_P1,MYIE1_P1
2401 !-----------------------------------------------------------------------
2402 KOFF=KTE-LMH(I,J)
2403 !
2404 E3(KTE)=Q2(I,KTE,J)*0.5
2405 !
2406 DO K=KTE-1,KOFF+1,-1
2407 E3(K)=MAX((Q2(I,K+1,J)+Q2(I,K,J))*0.5,EPSQ2)
2408 ENDDO
2409 !
2410 DO K=KOFF+1,KTE
2411 E4(K)=E3(K)
2412 ENDDO
2413 !
2414 PETDTK(KTE)=PETDT(I,KTE-1,J)*0.5
2415 !
2416 DO K=KTE-1,KOFF+2,-1
2417 PETDTK(K)=(PETDT(I,K+1,J)+PETDT(I,K,J))*0.5
2418 ENDDO
2419 !
2420 PETDTK(KOFF+1)=PETDT(I,KOFF+1,J)*0.5
2421 !-----------------------------------------------------------------------
2422 HADDT=-ADDT*HBM2(I,J)
2423 !
2424 DO K=KTE,KOFF+1,-1
2425 RR=PETDTK(K)*HADDT
2426 !
2427 IF(RR<0.)THEN
2428 LAP=1
2429 ELSE
2430 LAP=-1
2431 ENDIF
2432 !
2433 LA(K)=LAP
2434 LLAP=K+LAP
2435 !
2436 TOP=.FALSE.
2437 BOT=.FALSE.
2438 !
2439 IF(LLAP>0.AND.LLAP<KTE+1.AND.LAP/=0)THEN
2440 RR=ABS(RR/((AETA1(LLAP)-AETA1(K))*PDTOP &
2441 & +(AETA2(LLAP)-AETA2(K))*PDSL(I,J)))
2442 !
2443 AFR(K)=(((FF4*RR+FF3)*RR+FF2)*RR+FF1)*RR
2444 DEP=(E3(LLAP)-E3(K))*RR
2445 DEL(K)=DEP
2446 ELSE
2447 TOP=LLAP==KTE+1
2448 BOT=LLAP==KOFF
2449 !
2450 RR=0.
2451 AFR(K)=0.
2452 DEL(K)=0.
2453 ENDIF
2454 ENDDO
2455 !-----------------------------------------------------------------------
2456 IF(TOP)THEN
2457 IF(LA(KTE-1)<0)THEN
2458 RFC=(DETA1(KTE-1)*PDTOP+DETA2(KTE-1)*PDSL(I,J)) &
2459 & /(DETA1(KTE )*PDTOP+DETA2(KTE )*PDSL(I,J))
2460 DEL(KTE)=-DEL(KTE+1)*RFC
2461 ENDIF
2462 ENDIF
2463 !
2464 IF(BOT)THEN
2465 IF(LA(KOFF+2)<0)THEN
2466 RFC=(DETA1(KOFF+2)*PDTOP+DETA2(KOFF+2)*PDSL(I,J)) &
2467 & /(DETA1(KOFF+1)*PDTOP+DETA2(KOFF+1)*PDSL(I,J))
2468 DEL(KOFF+1)=-DEL(KOFF+2)*RFC
2469 ENDIF
2470 ENDIF
2471 !
2472 DO K=KOFF+1,KTE
2473 E4(K)=E3(K)+DEL(K)
2474 ENDDO
2475 !-----------------------------------------------------------------------
2476 !*** ANTI-FILTERING STEP
2477 !-----------------------------------------------------------------------
2478 SUMPE=0.
2479 SUMNE=0.
2480 !
2481 !*** ANTI-FILTERING LIMITERS
2482 !
2483 DO 50 K=KTE-1,KOFF+2,-1
2484 !
2485 DETAP=DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J)
2486 !
2487 E4P=E4(K)
2488 !
2489 LAP=LA(K)
2490 !
2491 IF(LAP/=0)THEN
2492 DPDN=(AETA1(K+LAP)-AETA1(K))*PDTOP &
2493 & +(AETA2(K+LAP)-AETA2(K))*PDSL(I,J)
2494 DPUP=(AETA1(K)-AETA1(K-LAP))*PDTOP &
2495 & +(AETA2(K)-AETA2(K-LAP))*PDSL(I,J)
2496 !
2497 AFRP=2.*AFR(K)*DPDN*DPDN/(DPDN+DPUP)
2498 D2PQE=((E4(K+LAP)-E4P)/DPDN &
2499 & -(E4P-E4(K-LAP))/DPUP)*AFRP
2500 ELSE
2501 D2PQE=0.
2502 ENDIF
2503 !
2504 EP=E4P-D2PQE
2505 !
2506 E00=E3(K)
2507 EP0=E3(K+LAP)
2508 !
2509 IF(LAP/=0)THEN
2510 EP=MAX(EP,MIN(E00,EP0))
2511 EP=MIN(EP,MAX(E00,EP0))
2512 ENDIF
2513 !
2514 DEP=EP-E00
2515 !
2516 DEL(K)=DEP
2517 !
2518 DEP=DEP*DETAP
2519 !
2520 IF(DEP>0.)THEN
2521 SUMPE=SUMPE+DEP
2522 ELSE
2523 SUMNE=SUMNE+DEP
2524 ENDIF
2525 !
2526 50 CONTINUE
2527 !-----------------------------------------------------------------------
2528 DEL(KTE)=0.
2529 !
2530 DEL(KOFF+1)=0.
2531 !-----------------------------------------------------------------------
2532 !*** FIRST MOMENT CONSERVING FACTOR
2533 !-----------------------------------------------------------------------
2534 IF(SUMPE>1.E-9)THEN
2535 RFACEK=-SUMNE/SUMPE
2536 ELSE
2537 RFACEK=1.
2538 ENDIF
2539 !
2540 IF(RFACEK<CONSERVE_MIN.OR.RFACEK>CONSERVE_MAX)RFACEK=1.
2541 !-----------------------------------------------------------------------
2542 !*** IMPOSE CONSERVATION ON ANTI-FILTERING
2543 !-----------------------------------------------------------------------
2544 DO K=KOFF+1,KTE
2545 DEP=DEL(K)
2546 IF(DEP>=0.)DEP=DEP*RFACEK
2547 E3(K)=E3(K)+DEP
2548 ENDDO
2549 !
2550 HBM2IJ=HBM2(I,J)
2551 Q2(I,KTE,J)=MAX(E3(KTE)+E3(KTE)-EPSQ2,EPSQ2)*HBM2IJ &
2552 & +Q2(I,KTE,J)*(1.-HBM2IJ)
2553 DO K=KTE-1,KOFF+2
2554 Q2(I,K,J)=MAX(E3(K)+E3(K)-Q2(I,K+1,J),EPSQ2)*HBM2IJ &
2555 & +Q2(I,K,J)*(1.-HBM2IJ)
2556 ENDDO
2557 !-----------------------------------------------------------------------
2558 !-----------------------------------------------------------------------
2559 ENDDO
2560 !
2561 ENDDO main_integration
2562 !-----------------------------------------------------------------------
2563 !----------------------------------------------------------------------
2564 END SUBROUTINE VAD2_DRY
2565 !----------------------------------------------------------------------
2566 !
2567 !***********************************************************************
2568 SUBROUTINE HAD2_DRY(NTSD,DT,IDTAD,DX,DY &
2569 & ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP &
2570 & ,HTM,HBM2,HBM3,LMH &
2571 & ,Q2,U,V,Z,HYDRO &
2572 & ,N_IUP_H,N_IUP_V &
2573 & ,N_IUP_ADH,N_IUP_ADV &
2574 & ,IUP_H,IUP_V,IUP_ADH,IUP_ADV &
2575 & ,IHE,IHW,IVE,IVW,INDX3_WRK &
2576 & ,IDS,IDE,JDS,JDE,KDS,KDE &
2577 & ,IMS,IME,JMS,JME,KMS,KME &
2578 & ,ITS,ITE,JTS,JTE,KTS,KTE)
2579 !***********************************************************************
2580 !$$$ SUBPROGRAM DOCUMENTATION BLOCK
2581 ! . . .
2582 ! SUBPROGRAM: HAD2_DRY HORIZONTAL ADVECTION OF TKE
2583 ! PRGRMMR: JANJIC ORG: W/NP22 DATE: 96-07-19
2584 !
2585 ! ABSTRACT:
2586 ! HAD2 CALCULATES THE CONTRIBUTION OF THE HORIZONTAL ADVECTION
2587 ! TO THE TENDENCIES OF TKE AND UPDATES IT.
2588 ! AN ANTI-FILTERING TECHNIQUE IS USED.
2589 !
2590 ! PROGRAM HISTORY LOG:
2591 ! 96-07-19 JANJIC - ORIGINATOR
2592 ! 98-11-02 BLACK - MODIFIED FOR DISTRIBUTED MEMORY
2593 ! 99-03-17 TUCCILLO - INCORPORATED MPI_ALLREDUCE FOR GLOBAL SUM
2594 ! 02-02-06 BLACK - CONVERTED TO WRF FORMAT
2595 ! 02-09-06 WOLFE - MORE CONVERSION TO GLOBAL INDEXING
2596 ! 03-05-23 JANJIC - ADDED SLOPE FACTOR
2597 ! 04-11-23 BLACK - THREADED
2598 !
2599 ! USAGE: CALL HAD2_DRY FROM SUBROUTINE DIGITAL_FILTER
2600 ! INPUT ARGUMENT LIST:
2601 !
2602 ! OUTPUT ARGUMENT LIST
2603 !
2604 ! OUTPUT FILES:
2605 ! NONE
2606 ! SUBPROGRAMS CALLED:
2607 !
2608 ! UNIQUE: NONE
2609 !
2610 ! LIBRARY: NONE
2611 !
2612 ! ATTRIBUTES:
2613 ! LANGUAGE: FORTRAN 90
2614 ! MACHINE : IBM SP
2615 !$$$
2616 !**********************************************************************
2617 !----------------------------------------------------------------------
2618 !
2619 IMPLICIT NONE
2620 !
2621 !----------------------------------------------------------------------
2622 !
2623 INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
2624 & ,IMS,IME,JMS,JME,KMS,KME &
2625 & ,ITS,ITE,JTS,JTE,KTS,KTE
2626 !
2627 INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
2628 INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: N_IUP_H,N_IUP_V &
2629 & ,N_IUP_ADH,N_IUP_ADV
2630 INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: IUP_H,IUP_V &
2631 & ,IUP_ADH,IUP_ADV
2632 ! NMM_MAX_DIM is set in configure.wrf and must agree with
2633 ! the value of dimspec q in the Registry/Registry
2634 INTEGER,DIMENSION(-3:3,NMM_MAX_DIM,0:6),INTENT(IN) :: INDX3_WRK
2635 !
2636 INTEGER,INTENT(IN) :: IDTAD,NTSD
2637 !
2638 INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: LMH
2639 !
2640 REAL,INTENT(IN) :: DT,DY,PDTOP
2641 !
2642 REAL,DIMENSION(KMS:KME),INTENT(IN) :: AETA1,AETA2,DETA1,DETA2
2643 !
2644 REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DX,HBM2,HBM3,PDSL
2645 !
2646 REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: HTM,U,V,Z
2647 !
2648 REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: Q2
2649 !
2650 LOGICAL,INTENT(IN) :: HYDRO
2651 !
2652 !----------------------------------------------------------------------
2653 !
2654 !*** LOCAL VARIABLES
2655 !
2656 REAL,PARAMETER :: FF1=0.530
2657 !
2658 LOGICAL :: BOT,TOP
2659 !
2660 INTEGER :: I,IRECV,J,JFP,JFQ,K,KOFF,LAP,LLAP,MPI_COMM_COMP
2661 !
2662 INTEGER,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: IFPA,IFPF &
2663 & ,IFQA,IFQF &
2664 & ,JFPA,JFPF &
2665 & ,JFQA,JFQF
2666 !
2667 REAL :: ADDT,AFRP,CRIT,D2PQE,DEP,DESTIJ,DVOLP,DZA,DZB &
2668 & ,E00,E0Q,E2IJ,E4P,ENH,EP,EP0,ESTIJ,FPQ &
2669 & ,HAFP,HAFQ,HBM2IJ,HM,HTMIKJ,PP,PPQ00 &
2670 & ,QP,RDY,RFACEK,RFC,RFEIJ,RR &
2671 & ,SLOPAC,SPP,SQP,SSA,SSB,SUMNE,SUMPE,TTA,TTB
2672 !
2673 REAL,DIMENSION(2,KTE-KTS+1) :: GSUMS,XSUMS
2674 !
2675 REAL,DIMENSION(KTS:KTE) :: AFR,DEL,E3,E4,RFACE
2676 !
2677 REAL,DIMENSION(IMS:IME,JMS:JME) :: DARE,EMH
2678 !
2679 REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: AFP,AFQ,DEST,DVOL &
2680 & ,E1,E2
2681 !
2682 !***********************************************************************
2683 !-----------------------------------------------------------------------
2684 RDY=1./DY
2685 SLOPAC=SLOPHT*SQRT(2.)*0.5*50.
2686 CRIT=SLOPAC*REAL(IDTAD)*DT*RDY*1000.
2687 !
2688 ADDT=REAL(IDTAD)*DT
2689 ENH=ADDT/(08.*DY)
2690 !
2691 !-----------------------------------------------------------------------
2692 !$omp parallel do &
2693 !$omp& private(i,j)
2694 DO J=MYJS_P3,MYJE_P3
2695 DO I=MYIS_P2,MYIE_P2
2696 EMH (I,J)=ADDT/(08.*DX(I,J))
2697 DARE(I,J)=HBM3(I,J)*DX(I,J)*DY
2698 E1(I,KTE,J)=MAX(Q2(I,KTE,J)*0.5,EPSQ2)
2699 E2(I,KTE,J)=E1(I,KTE,J)
2700 ENDDO
2701 ENDDO
2702 !-----------------------------------------------------------------------
2703 !$omp parallel do &
2704 !$omp& private(i,j,k)
2705 DO J=MYJS_P3,MYJE_P3
2706 !
2707 DO K=KTS,KTE
2708 DO I=MYIS_P2,MYIE_P2
2709 DVOL(I,K,J)=DARE(I,J)*(DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J))
2710 ENDDO
2711 ENDDO
2712 !
2713 DO K=KTE-1,KTS,-1
2714 DO I=MYIS_P2,MYIE_P2
2715 E1(I,K,J)=MAX((Q2(I,K+1,J)+Q2(I,K,J))*0.5,EPSQ2)
2716 E2(I,K,J)=E1(I,K,J)
2717 ENDDO
2718 ENDDO
2719 !
2720 ENDDO
2721 !-----------------------------------------------------------------------
2722 !$omp parallel do &
2723 !$omp& private(dza,dzb,fpq,i,j,jfp,jfq,k,pp,qp,spp,sqp,ssa,ssb,tta,ttb)
2724 DO J=MYJS2_P1,MYJE2_P1
2725 DO K=KTS,KTE
2726 DO I=MYIS1_P1,MYIE1_P1
2727 !
2728 TTA=(U(I,K,J-1)+U(I+IHW(J),K,J)+U(I+IHE(J),K,J)+U(I,K,J+1)) &
2729 & *EMH(I,J)*HBM2(I,J)
2730 TTB=(V(I,K,J-1)+V(I+IHW(J),K,J)+V(I+IHE(J),K,J)+V(I,K,J+1)) &
2731 & *ENH*HBM2(I,J)
2732 !
2733 SPP=-TTA-TTB
2734 SQP= TTA-TTB
2735 !
2736 IF(SPP<0.)THEN
2737 JFP=-1
2738 ELSE
2739 JFP=1
2740 ENDIF
2741 IF(SQP<0.)THEN
2742 JFQ=-1
2743 ELSE
2744 JFQ=1
2745 ENDIF
2746 !
2747 IFPA(I,K,J)=IHE(J)+I+( JFP-1)/2
2748 IFQA(I,K,J)=IHE(J)+I+(-JFQ-1)/2
2749 !
2750 JFPA(I,K,J)=J+JFP
2751 JFQA(I,K,J)=J+JFQ
2752 !
2753 IFPF(I,K,J)=IHE(J)+I+(-JFP-1)/2
2754 IFQF(I,K,J)=IHE(J)+I+( JFQ-1)/2
2755 !
2756 JFPF(I,K,J)=J-JFP
2757 JFQF(I,K,J)=J-JFQ
2758 !
2759 !------------------------------------------------------------------------
2760 IF(.NOT.HYDRO)THEN ! z currently not available for hydro=.true.
2761 DZA=(Z(IFPA(I,K,J),K,JFPA(I,K,J))-Z(I,K,J))*RDY
2762 DZB=(Z(IFQA(I,K,J),K,JFQA(I,K,J))-Z(I,K,J))*RDY
2763 !
2764 IF(ABS(DZA)>SLOPAC)THEN
2765 SSA=DZA*SPP
2766 IF(SSA>CRIT)THEN
2767 SPP=0. !spp*.1
2768 ENDIF
2769 ENDIF
2770 !
2771 IF(ABS(DZB)>SLOPAC)THEN
2772 SSB=DZB*SQP
2773 IF(SSB>CRIT)THEN
2774 SQP=0. !sqp*.1
2775 ENDIF
2776 ENDIF
2777 !
2778 ENDIF
2779 !-----------------------------------------------------------------------
2780 SPP=SPP*HTM(IFPA(I,K,J),K,JFPA(I,K,J))
2781 SQP=SQP*HTM(IFQA(I,K,J),K,JFQA(I,K,J))
2782 FPQ=SPP*SQP*HTM(I,K,J-2)*HTM(I-1,K,J) &
2783 & *HTM(I+1,K,J)*HTM(I,K,J+2)*0.25
2784 PP=ABS(SPP)
2785 QP=ABS(SQP)
2786 !
2787 AFP(I,K,J)=(((FF4*PP+FF3)*PP+FF2)*PP+FF1)*PP
2788 AFQ(I,K,J)=(((FF4*QP+FF3)*QP+FF2)*QP+FF1)*QP
2789 !
2790 E2(I,K,J)=(E1 (IFPA(I,K,J),K,JFPA(I,K,J))-E1 (I,K,J))*PP &
2791 & +(E1 (IFQA(I,K,J),K,JFQA(I,K,J))-E1 (I,K,J))*QP &
2792 & +(E1 (I,K,J-2)+E1 (I,K,J+2) &
2793 & -E1 (I-1,K,J)-E1 (I+1,K,J))*FPQ &
2794 & +E1(I,K,J)
2795 !
2796 ENDDO
2797 ENDDO
2798 ENDDO
2799 !
2800 !-----------------------------------------------------------------------
2801 !*** ANTI-FILTERING STEP
2802 !-----------------------------------------------------------------------
2803 !
2804 DO K=KTS,KTE
2805 XSUMS(1,K)=0.
2806 XSUMS(2,K)=0.
2807 ENDDO
2808 !
2809 !--------------ANTI-FILTERING LIMITERS----------------------------------
2810 !
2811 DO 150 J=MYJS2,MYJE2
2812 DO 150 K=KTS,KTE
2813 DO 150 I=MYIS1,MYIE1
2814 !
2815 DVOLP=DVOL(I,K,J)
2816 E2IJ =E2(I,K,J)
2817 !
2818 HAFP=HTM(IFPF(I,K,J),K,JFPF(I,K,J))*AFP(I,K,J)
2819 HAFQ=HTM(IFQF(I,K,J),K,JFQF(I,K,J))*AFQ(I,K,J)
2820 !
2821 D2PQE=(E2(IFPA(I,K,J),K,JFPA(I,K,J))-E2IJ &
2822 & -E2IJ+E2(IFPF(I,K,J),K,JFPF(I,K,J))) &
2823 & *HAFP &
2824 & +(E2(IFQA(I,K,J),K,JFQA(I,K,J))-E2IJ &
2825 & -E2IJ+E2(IFQF(I,K,J),K,JFQF(I,K,J))) &
2826 & *HAFQ
2827 !
2828 ESTIJ=E2IJ-D2PQE
2829 !
2830 E00=E1 (I ,K ,J)
2831 EP0=E1 (IFPA(I,K,J),K,JFPA(I,K,J))
2832 E0Q=E1 (IFQA(I,K,J),K,JFQA(I,K,J))
2833 !
2834 ESTIJ=MAX(ESTIJ,MIN(E00,EP0,E0Q))
2835 ESTIJ=MIN(ESTIJ,MAX(E00,EP0,E0Q))
2836 !
2837 DESTIJ=ESTIJ-E1(I,K,J)
2838 DEST(I,K,J)=DESTIJ
2839 !
2840 DESTIJ=DESTIJ*DVOLP
2841 !
2842 IF(DESTIJ>0.)THEN
2843 XSUMS(1,K)=XSUMS(1,K)+DESTIJ
2844 ELSE
2845 XSUMS(2,K)=XSUMS(2,K)+DESTIJ
2846 ENDIF
2847 !
2848 150 CONTINUE
2849 !-----------------------------------------------------------------------
2850 !
2851 !-----------------------------------------------------------------------
2852 !*** GLOBAL REDUCTION
2853 !-----------------------------------------------------------------------
2854 !
2855 #ifdef DM_PARALLEL
2856 CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP)
2857 CALL MPI_ALLREDUCE(XSUMS,GSUMS,2*(KTE-KTS+1),MPI_REAL,MPI_SUM &
2858 & ,MPI_COMM_COMP,IRECV)
2859 #else
2860 GSUMS=XSUMS
2861 #endif
2862 !
2863 !-----------------------------------------------------------------------
2864 !*** END OF GLOBAL REDUCTION
2865 !-----------------------------------------------------------------------
2866 !
2867 DO K=KTS,KTE
2868 !
2869 !-----------------------------------------------------------------------
2870 SUMPE=GSUMS(1,K)
2871 SUMNE=GSUMS(2,K)
2872 !
2873 !-----------------------------------------------------------------------
2874 !*** FIRST MOMENT CONSERVING FACTOR
2875 !-----------------------------------------------------------------------
2876 !
2877 IF(SUMPE>1.)THEN
2878 RFACEK=-SUMNE/SUMPE
2879 ELSE
2880 RFACEK=1.
2881 ENDIF
2882 !
2883 IF(RFACEK<CONSERVE_MIN.OR.RFACEK>CONSERVE_MAX)RFACEK=1.
2884 !
2885 RFACE(K)=RFACEK
2886 !
2887 ENDDO
2888 !
2889 !-----------------------------------------------------------------------
2890 !*** IMPOSE CONSERVATION ON ANTI-FILTERING
2891 !-----------------------------------------------------------------------
2892 !$omp parallel do &
2893 !$omp& private(destij,i,j,k,rfacek,rfeij)
2894 DO J=MYJS2,MYJE2
2895 DO K=KTS,KTE
2896 RFACEK=RFACE(K)
2897 IF(RFACEK<1.)THEN
2898 DO I=MYIS1,MYIE1
2899 DESTIJ=DEST(I,K,J)
2900 RFEIJ=HBM2(I,J)*(RFACEK-1.)+1.
2901 IF(DESTIJ>=0.)DESTIJ=DESTIJ*RFEIJ
2902 E1(I,K,J)=E1(I,K,J)+DESTIJ
2903 ENDDO
2904 ELSE
2905 DO I=MYIS1,MYIE1
2906 DESTIJ=DEST(I,K,J)
2907 RFEIJ=HBM2(I,J)*(RFACEK-1.)+1.
2908 IF(DESTIJ<0.)DESTIJ=DESTIJ/RFEIJ
2909 E1(I,K,J)=E1(I,K,J)+DESTIJ
2910 ENDDO
2911 ENDIF
2912 ENDDO
2913 ENDDO
2914 !-----------------------------------------------------------------------
2915 !$omp parallel do &
2916 !$omp& private(i,j)
2917 DO J=MYJS,MYJE
2918 DO I=MYIS,MYIE
2919 Q2(I,KTE,J)=MAX(E1(I,KTE,J)+E1(I,KTE,J)-EPSQ2,EPSQ2) &
2920 & *HTM(I,KTE,J)
2921 ENDDO
2922 ENDDO
2923 !
2924 !$omp parallel do &
2925 !$omp& private(i,j,k,koff)
2926 DO J=MYJS,MYJE
2927 DO K=KTE-1,KTS+1,-1
2928 DO I=MYIS,MYIE
2929 KOFF=KTE-LMH(I,J)
2930 IF(K>KOFF+1)THEN
2931 Q2(I,K,J)=MAX(E1(I,K,J)+E1(I,K,J)-Q2(I,K+1,J),EPSQ2) &
2932 & *HTM(I,K,J)
2933 ELSE
2934 Q2(I,K,J)=Q2(I,K+1,J)
2935 ENDIF
2936 ENDDO
2937 ENDDO
2938 ENDDO
2939 !-----------------------------------------------------------------------
2940 END SUBROUTINE HAD2_DRY
2941 !-----------------------------------------------------------------------
2942 !-----------------------------------------------------------------------
2943 !^L
2944 ! New routines added by Georg Grell to handle advection more like ARW
2945 ! core. Instead of VAD2/HAD2 that advect TKE, specific humidity, and
2946 ! condensed water species all in one routine, we call VAD2/HAD2_SCAL
2947 ! with multidimensioned arrays to advect each variable. For purposes
2948 ! here, solve_nmm.F calls this routine once for TKE, then again for
2949 ! all the species held in the moist array (qv, qc, qi, qr, qs, qg),
2950 ! then call again for number concentrations held in scalar array (qni).
2951 ! The dummy argument lstart is the starting index of the multidimensioned
2952 ! array for starting the advection since the 1st index of moist and
2953 ! scalar are actually empty placeholders (and the 2nd element is vapor,
2954 ! then qc, etc.) When calling with single 3D array (like TKE), just
2955 ! set NUM_SCAL=1 and lstart=1. The variable to advect is called SCAL
2956 ! herein.
2957 !***********************************************************************
2958 SUBROUTINE VAD2_SCAL(NTSD,DT,IDTAD,DX,DY &
2959 & ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP &
2960 & ,HBM2,LMH &
2961 & ,SCAL,PETDT &
2962 & ,N_IUP_H,N_IUP_V &
2963 & ,N_IUP_ADH,N_IUP_ADV &
2964 & ,IUP_H,IUP_V,IUP_ADH,IUP_ADV &
2965 & ,IHE,IHW,IVE,IVW,INDX3_WRK &
2966 & ,NUM_SCAL,lstart &
2967 & ,IDS,IDE,JDS,JDE,KDS,KDE &
2968 & ,IMS,IME,JMS,JME,KMS,KME &
2969 & ,ITS,ITE,JTS,JTE,KTS,KTE)
2970 !***********************************************************************
2971 !$$$ SUBPROGRAM DOCUMENTATION BLOCK
2972 ! . . .
2973 ! SUBPROGRAM: VAD2_SCAL VERTICAL ADVECTION OF SCALARS
2974 !
2975 ! PRGRMMR: JANJIC ORG: W/NP22 DATE: 96-07-19
2976 ! GRELL,PECKHAM ORG: NOAA/FSL DATE: 05-02-03
2977 !
2978 ! ABSTRACT:
2979 ! VAD2_SCAL CALCULATES THE CONTRIBUTION OF THE VERTICAL ADVECTION
2980 ! TO THE TENDENCIES OF SCALAR SUBSTANCES AND THEN UPDATES
2981 ! THOSE VARIABLES. AN ANTI-FILTERING TECHNIQUE IS USED.
2982 !
2983 ! PROGRAM HISTORY LOG:
2984 ! 96-07-19 JANJIC - ORIGINATOR
2985 ! 05-02-03 GRELL,PECKHAM - MODIFIED FOR SCALARS
2986 !
2987 ! USAGE: CALL VAD2_SCAL FROM SUBROUTINE SOLVE_NMM
2988 ! INPUT ARGUMENT LIST:
2989 !
2990 ! OUTPUT ARGUMENT LIST
2991 !
2992 ! OUTPUT FILES:
2993 ! NONE
2994 ! SUBPROGRAMS CALLED:
2995 !
2996 ! UNIQUE: NONE
2997 !
2998 ! LIBRARY: NONE
2999 !
3000 ! ATTRIBUTES:
3001 ! LANGUAGE: FORTRAN 90
3002 ! MACHINE : IBM SP
3003 !$$$
3004 !***********************************************************************
3005 !----------------------------------------------------------------------
3006 !
3007 IMPLICIT NONE
3008 !
3009 !----------------------------------------------------------------------
3010 !
3011 INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
3012 & ,IMS,IME,JMS,JME,KMS,KME &
3013 ,ITS,ITE,JTS,JTE,KTS,KTE
3014
3015 INTEGER,INTENT(IN) :: NUM_SCAL, lstart
3016 !
3017 INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
3018 INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: N_IUP_H,N_IUP_V &
3019 & ,N_IUP_ADH,N_IUP_ADV
3020 INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: IUP_H,IUP_V &
3021 & ,IUP_ADH,IUP_ADV
3022 ! NMM_MAX_DIM is set in configure.wrf and must agree with
3023 ! the value of dimspec q in the Registry/Registry
3024 INTEGER,DIMENSION(-3:3,NMM_MAX_DIM,0:6),INTENT(IN) :: INDX3_WRK
3025 !
3026 INTEGER,INTENT(IN) :: IDTAD,NTSD
3027 !
3028 INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: LMH
3029 !
3030 REAL,INTENT(IN) :: DT,DY,PDTOP
3031 !
3032 REAL,DIMENSION(KMS:KME),INTENT(IN) :: AETA1,AETA2,DETA1,DETA2
3033 !
3034 REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DX,HBM2,PDSL
3035 !
3036 REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: PETDT
3037 !
3038 REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME,1:NUM_SCAL),INTENT(INOUT) :: SCAL
3039 !
3040 !----------------------------------------------------------------------
3041 !
3042 !*** LOCAL VARIABLES
3043 !
3044 REAL,PARAMETER :: FF1=0.525
3045 !
3046 LOGICAL :: BOT,TOP
3047 !
3048 INTEGER :: I,IRECV,J,JFP,JFQ,K,KOFF,LAP,LLAP, L
3049 !
3050 INTEGER,DIMENSION(KTS:KTE) :: LA
3051 !
3052 REAL*8 :: ADDT,AFRP,D2PQE,D2PQQ,D2PQW,DEP,DETAP,DPDN,DPUP,DQP &
3053 & ,DWP,E00,E4P,EP,EP0,HADDT,HBM2IJ &
3054 & ,Q00,Q4P,QP,QP0 &
3055 & ,RFACEK,RFACQK,RFACWK,RFC,RR &
3056 & ,SUMNE,SUMNQ,SUMNW,SUMPE,SUMPQ,SUMPW &
3057 & ,W00,W4P,WP,WP0
3058 REAL,DIMENSION(KTS:KTE) :: AFR,DEL,DQL,DWL,E3,E4,PETDTK &
3059 & ,RFACE,RFACQ,RFACW,Q3,Q4,W3,W4
3060 !
3061 !***********************************************************************
3062 !-----------------------------------------------------------------------
3063 !
3064 ADDT=REAL(IDTAD)*DT
3065 !
3066 !-----------------------------------------------------------------------
3067 !
3068 !$omp parallel do &
3069 !$omp& private(afr,afrp,bot,d2pqe,d2pqq,d2pqw,del,dep,detap,dpdn,dpup &
3070 !$omp& ,dql,dqp,dwl,dwp,e00,e3,e4,e4p,ep,ep0,haddt,i,j,k,koff &
3071 !$omp& ,la,lap,llap,petdtk,q00,q3,q4,q4p,qp,qp0,rfacek,rfacqk &
3072 !$omp& ,rfacwk,rfc,rr,sumne,sumnq,sumnw,sumpe,sumpq,sumpw,top &
3073 !$omp& ,w00,w3,w4,w4p,wp,wp0)
3074
3075 scalar_loop : DO L=lstart,NUM_SCAL
3076 main_integration : DO J=MYJS2,MYJE2
3077 !
3078 DO I=MYIS1_P1,MYIE1_P1
3079 !-----------------------------------------------------------------------
3080 KOFF=KTE-LMH(I,J)
3081 !
3082 DO K=KOFF+1,KTE
3083 ! Q3(K)=MAX(SCAL(I,K,J,L),EPSILSCALAR)
3084 Q3(K)=SCAL(I,K,J,L)
3085 Q4(K)=Q3(K)
3086 ENDDO
3087 !
3088 PETDTK(KTE)=PETDT(I,KTE-1,J)*0.5
3089 !
3090 DO K=KTE-1,KOFF+2,-1
3091 PETDTK(K)=(PETDT(I,K,J)+PETDT(I,K-1,J))*0.5
3092 ENDDO
3093 !
3094 PETDTK(KOFF+1)=PETDT(I,KOFF+1,J)*0.5
3095 !-----------------------------------------------------------------------
3096 HADDT=-ADDT*HBM2(I,J)
3097 !
3098 DO K=KTE,KOFF+1,-1
3099 RR=PETDTK(K)*HADDT
3100 !
3101 IF(RR<0.)THEN
3102 LAP=1
3103 ELSE
3104 LAP=-1
3105 ENDIF
3106 !
3107 LA(K)=LAP
3108 LLAP=K+LAP
3109 !
3110 TOP=.FALSE.
3111 BOT=.FALSE.
3112 !
3113 IF(LLAP>KOFF.AND.LLAP<KTE+1.AND.LAP/=0)THEN
3114 RR=ABS(RR/((AETA1(LLAP)-AETA1(K))*PDTOP &
3115 & +(AETA2(LLAP)-AETA2(K))*PDSL(I,J)))
3116 !
3117 AFR(K)=(((FF4*RR+FF3)*RR+FF2)*RR+FF1)*RR
3118 DQP=(Q3(LLAP)-Q3(K))*RR
3119 DQL(K)=DQP
3120 ELSE
3121 TOP=LLAP==KTE+1
3122 BOT=LLAP==KOFF
3123 !
3124 RR=0.
3125 AFR(K)=0.
3126 DQL(K)=0.
3127 ENDIF
3128 ENDDO
3129 !-----------------------------------------------------------------------
3130 IF(TOP)THEN
3131 IF(LA(KTE-1)>0)THEN
3132 RFC=(DETA1(KTE-1)*PDTOP+DETA2(KTE-1)*PDSL(I,J)) &
3133 & /(DETA1(KTE )*PDTOP+DETA2(KTE )*PDSL(I,J))
3134 DQL(KTE)=-DQL(KTE+1)*RFC
3135 ENDIF
3136 ENDIF
3137 !
3138 IF(BOT)THEN
3139 IF(LA(KOFF+2)<0)THEN
3140 RFC=(DETA1(KOFF+2)*PDTOP+DETA2(KOFF+2)*PDSL(I,J)) &
3141 & /(DETA1(KOFF+1)*PDTOP+DETA2(KOFF+1)*PDSL(I,J))
3142 DQL(KOFF+1)=-DQL(KOFF+2)*RFC
3143 ENDIF
3144 ENDIF
3145 !
3146 DO K=KOFF+1,KTE
3147 Q4(K)=Q3(K)+DQL(K)
3148 ENDDO
3149 !-----------------------------------------------------------------------
3150 !*** ANTI-FILTERING STEP
3151 !-----------------------------------------------------------------------
3152 SUMPQ=0.
3153 SUMNQ=0.
3154 !
3155 !*** ANTI-FILTERING LIMITERS
3156 !
3157 DO 50 K=KTE-1,KOFF+2,-1
3158 !
3159 DETAP=DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J)
3160 !
3161 Q4P=Q4(K)
3162 !
3163 LAP=LA(K)
3164 !
3165 IF(LAP.NE.0)THEN
3166 DPDN=(AETA1(K+LAP)-AETA1(K))*PDTOP &
3167 & +(AETA2(K+LAP)-AETA2(K))*PDSL(I,J)
3168 DPUP=(AETA1(K)-AETA1(K-LAP))*PDTOP &
3169 & +(AETA2(K)-AETA2(K-LAP))*PDSL(I,J)
3170 !
3171 AFRP=2.*AFR(K)*DPDN*DPDN/(DPDN+DPUP)
3172 D2PQQ=((Q4(K+LAP)-Q4P)/DPDN &
3173 & -(Q4P-Q4(K-LAP))/DPUP)*AFRP
3174 ELSE
3175 D2PQQ=0.
3176 ENDIF
3177 !
3178 QP=Q4P-D2PQQ
3179 !
3180 Q00=Q3(K)
3181 QP0=Q3(K+LAP)
3182 !
3183 IF(LAP/=0)THEN
3184 QP=MAX(QP,MIN(Q00,QP0))
3185 QP=MIN(QP,MAX(Q00,QP0))
3186 ENDIF
3187 !
3188 DQP=QP-Q00
3189 !
3190 DQL(K)=DQP
3191 !
3192 DQP=DQP*DETAP
3193 !
3194 IF(DQP>0.)THEN
3195 SUMPQ=SUMPQ+DQP
3196 ELSE
3197 SUMNQ=SUMNQ+DQP
3198 ENDIF
3199 !
3200 50 CONTINUE
3201 !-----------------------------------------------------------------------
3202 DQL(KOFF+1)=0.
3203 !
3204 DQL(KTE)=0.
3205 !-----------------------------------------------------------------------
3206 !*** FIRST MOMENT CONSERVING FACTOR
3207 !-----------------------------------------------------------------------
3208 IF(SUMPQ>1.E-9)THEN
3209 RFACQK=-SUMNQ/SUMPQ
3210 ELSE
3211 RFACQK=1.
3212 ENDIF
3213 !
3214 IF(RFACQK<CONSERVE_MIN.OR.RFACQK>CONSERVE_MAX)RFACQK=1.
3215 !-----------------------------------------------------------------------
3216 !*** IMPOSE CONSERVATION ON ANTI-FILTERING
3217 !-----------------------------------------------------------------------
3218 DO K=KTE,KOFF+1,-1
3219 DQP=DQL(K)
3220 IF(DQP>=0.)DQP=DQP*RFACQK
3221 SCAL(I,K,J,L)=Q3(K)+DQP
3222 ENDDO
3223 !
3224 ! HBM2IJ=HBM2(I,J)
3225 !-----------------------------------------------------------------------
3226 !-----------------------------------------------------------------------
3227 ENDDO
3228
3229 !
3230 ENDDO main_integration
3231 ENDDO scalar_loop
3232 !-----------------------------------------------------------------------
3233 !-----------------------------------------------------------------------
3234 END SUBROUTINE VAD2_SCAL
3235 !-----------------------------------------------------------------------
3236 !
3237 !***********************************************************************
3238 SUBROUTINE HAD2_SCAL( &
3239 #if defined(DM_PARALLEL)
3240 & domdesc , &
3241 #endif
3242 & NTSD,DT,IDTAD,DX,DY &
3243 & ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP &
3244 & ,HTM,HBM2,HBM3,LMH &
3245 & ,SCAL,U,V,Z,HYDRO &
3246 & ,N_IUP_H,N_IUP_V &
3247 & ,N_IUP_ADH,N_IUP_ADV &
3248 & ,IUP_H,IUP_V,IUP_ADH,IUP_ADV &
3249 & ,IHE,IHW,IVE,IVW,INDX3_WRK &
3250 & ,NUM_SCAL,lstart &
3251 & ,IDS,IDE,JDS,JDE,KDS,KDE &
3252 & ,IMS,IME,JMS,JME,KMS,KME &
3253 & ,ITS,ITE,JTS,JTE,KTS,KTE)
3254 !***********************************************************************
3255 !$$$ SUBPROGRAM DOCUMENTATION BLOCK
3256 ! . . .
3257 ! SUBPROGRAM: HAD2_SCAL HORIZONTAL ADVECTION OF SCALAR
3258 ! PRGRMMR: JANJIC ORG: W/NP22 DATE: 96-07-19
3259 ! GRELL,PECKHAM ORG: NOAA/FSL DATE: 05-02-03
3260 !
3261 ! ABSTRACT:
3262 ! HAD2_SCAL CALCULATES THE CONTRIBUTION OF THE HORIZONTAL ADVECTION
3263 ! TO THE TENDENCIES OF SCALAR SUBSTANCES AND THEN
3264 ! UPDATES THOSE VARIABLES. AN ANTI-FILTERING TECHNIQUE IS USED.
3265 !
3266 ! PROGRAM HISTORY LOG:
3267 ! 96-07-19 JANJIC - ORIGINATOR
3268 ! 05-01-03 GRELL,PECKKHAM - MODIFIED FOR SCALAR
3269 !
3270 ! USAGE: CALL HAD2_SCAL FROM SUBROUTINE SOLVE_NMM
3271 ! INPUT ARGUMENT LIST:
3272 !
3273 ! OUTPUT ARGUMENT LIST
3274 !
3275 ! OUTPUT FILES:
3276 ! NONE
3277 ! SUBPROGRAMS CALLED:
3278 !
3279 ! UNIQUE: NONE
3280 !
3281 ! LIBRARY: NONE
3282 !
3283 ! ATTRIBUTES:
3284 ! LANGUAGE: FORTRAN 90
3285 ! MACHINE : IBM SP
3286 !$$$
3287 !***********************************************************************
3288 !-----------------------------------------------------------------------
3289 !
3290 IMPLICIT NONE
3291 !
3292 !-----------------------------------------------------------------------
3293 !
3294 INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
3295 & ,IMS,IME,JMS,JME,KMS,KME &
3296 & ,ITS,ITE,JTS,JTE,KTS,KTE
3297
3298 INTEGER,INTENT(IN) :: NUM_SCAL, lstart
3299 !
3300 INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
3301 INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: N_IUP_H,N_IUP_V &
3302 & ,N_IUP_ADH,N_IUP_ADV
3303 INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: IUP_H,IUP_V &
3304 & ,IUP_ADH,IUP_ADV
3305 !-----------------------------------------------------------------------
3306 !!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3307 ! NMM_MAX_DIM is set in configure.wrf and must agree with the value of
3308 ! dimspec q in Registry/Registry.
3309 !!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3310 !-----------------------------------------------------------------------
3311 INTEGER,DIMENSION(-3:3,NMM_MAX_DIM,0:6),INTENT(IN) :: INDX3_WRK
3312 !
3313 INTEGER,INTENT(IN) :: IDTAD,NTSD
3314 !
3315 INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: LMH
3316 !
3317 REAL,INTENT(IN) :: DT,DY,PDTOP
3318 !
3319 REAL,DIMENSION(KMS:KME),INTENT(IN) :: AETA1,AETA2,DETA1,DETA2
3320 !
3321 REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DX,HBM2,HBM3,PDSL
3322 !
3323 REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: HTM,U,V,Z
3324 !
3325 !!!!! q is local. CORRECT DIMENSION???
3326 !jjjj
3327 !!!!! REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: Q
3328 REAL,DIMENSION(ITS-5:ITE+5,KTS:KTE,JTS-5:JTE+5) :: Q
3329 REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME,NUM_SCAL),INTENT(INOUT) :: SCAL
3330 !
3331 LOGICAL,INTENT(IN) :: HYDRO
3332 !
3333 !-----------------------------------------------------------------------
3334 !
3335 !*** LOCAL VARIABLES
3336 !
3337 REAL,PARAMETER :: FF1=0.530
3338 !
3339 #ifdef DM_PARALLEL
3340 INTEGER :: DOMDESC
3341 #endif
3342 !
3343 #if defined(BIT_FOR_BIT) && defined(DM_PARALLEL)
3344 LOGICAL,EXTERNAL :: WRF_DM_ON_MONITOR
3345 INTEGER :: N
3346 REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME,6) :: XSUMS_L
3347 REAL,DIMENSION(IDS:IDE,KDS:KDE,JDS:JDE,6) :: XSUMS_G
3348 #endif
3349 !
3350 LOGICAL :: BOT,TOP
3351 !
3352 INTEGER :: I,IRECV,J,JFP,JFQ,K,KOFF,LAP,LLAP,MPI_COMM_COMP, L
3353 !
3354 INTEGER,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: IFPA,IFPF &
3355 & ,IFQA,IFQF &
3356 & ,JFPA,JFPF &
3357 & ,JFQA,JFQF
3358 !
3359 REAL :: ADDT,AFRP,CRIT,D2PQE,D2PQQ,D2PQW,DEP,DESTIJ,DQP,DQSTIJ &
3360 & ,DVOLP,DWP,DWSTIJ,DZA,DZB,E00,E0Q,E1X,E2IJ,E4P,ENH,EP,EP0 &
3361 & ,ESTIJ,FPQ,HAFP,HAFQ,HBM2IJ,HM,HTMIKJ,PP,PPQ00,Q00,Q0Q &
3362 & ,Q1IJ,Q4P,QP,QP0,QSTIJ,RDY,RFACEK,RFACQK,RFACWK,RFC &
3363 & ,RFEIJ,RFQIJ,RFWIJ,RR,SLOPAC,SPP,SQP,SSA,SSB,SUMNE,SUMNQ &
3364 & ,SUMNW,SUMPE,SUMPQ,SUMPW,TTA,TTB,W00,W0Q,W1IJ,W4P,WP,WP0 &
3365 & ,WSTIJ
3366 !
3367 DOUBLE PRECISION,DIMENSION(6,KTE-KTS+1) :: GSUMS,XSUMS
3368 !
3369 REAL,DIMENSION(KTS:KTE) :: AFR,DEL,DQL,DWL,E3,E4 &
3370 & ,RFACE,RFACQ,RFACW,Q3,Q4,W3,W4
3371 !
3372 REAL,DIMENSION(IMS:IME,JMS:JME) :: DARE,EMH
3373 !
3374 REAL,DIMENSION(ITS-5:ITE+5,KTS:KTE,JTS-5:JTE+5) :: AFP,AFQ,DEST &
3375 & ,DQST,DVOL,DWST &
3376 & ,E1,E2,Q1,W1
3377 integer :: nunit,ier
3378 save nunit
3379 !***********************************************************************
3380 !-----------------------------------------------------------------------
3381 !
3382 RDY=1./DY
3383 SLOPAC=SLOPHT*SQRT(2.)*0.5*50.
3384 CRIT=SLOPAC*REAL(IDTAD)*DT*RDY*1000.
3385 !
3386 ADDT=REAL(IDTAD)*DT
3387 ENH=ADDT/(08.*DY)
3388 !
3389 !-----------------------------------------------------------------------
3390 !
3391 SCALAR_LOOP : DO L=lstart,NUM_SCAL
3392 !
3393 !-----------------------------------------------------------------------
3394 !$omp parallel do &
3395 !$omp& private(i,j)
3396 DO J=MYJS_P3,MYJE_P3
3397 DO I=MYIS_P2,MYIE_P2
3398 EMH (I,J)=ADDT/(08.*DX(I,J))
3399 DARE(I,J)=HBM3(I,J)*DX(I,J)*DY
3400 ! E1(I,KTE,J)=MAX(Q2(I,KTE,J)*0.5,EPSQ2)
3401 ! E2(I,KTE,J)=E1(I,KTE,J)
3402 ENDDO
3403 ENDDO
3404 !-----------------------------------------------------------------------
3405 !
3406 !$omp parallel do &
3407 !$omp& private(e1x,htmikj,i,j,k)
3408 DO J=MYJS_P3,MYJE_P3
3409 DO K=KTS,KTE
3410 DO I=MYIS_P2,MYIE_P2
3411 DVOL(I,K,J)=DARE(I,J)*(DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J))
3412 HTMIKJ=HTM(I,K,J)
3413 ! Q (I,K,J)=MAX(SCAL(I,K,J,L),EPSILSCALAR)*HTMIKJ
3414 Q (I,K,J)=SCAL(I,K,J,L)*HTMIKJ
3415 Q1 (I,K,J)=Q (I,K,J)
3416 ENDDO
3417 ENDDO
3418 !
3419 ENDDO
3420 !-----------------------------------------------------------------------
3421 !$omp parallel do &
3422 !$omp& private(dza,dzb,fpq,i,j,jfp,jfq,k,pp,qp,ssa,ssb,spp,sqp,tta,ttb)
3423 DO J=MYJS2_P1,MYJE2_P1
3424 DO K=KTS,KTE
3425 DO I=MYIS1_P1,MYIE1_P1
3426 !
3427 TTA=(U(I,K,J-1)+U(I+IHW(J),K,J)+U(I+IHE(J),K,J)+U(I,K,J+1)) &
3428 & *EMH(I,J)*HBM2(I,J)
3429 TTB=(V(I,K,J-1)+V(I+IHW(J),K,J)+V(I+IHE(J),K,J)+V(I,K,J+1)) &
3430 & *ENH*HBM2(I,J)
3431 !
3432 SPP=-TTA-TTB
3433 SQP= TTA-TTB
3434 !
3435 IF(SPP<0.)THEN
3436 JFP=-1
3437 ELSE
3438 JFP=1
3439 ENDIF
3440 IF(SQP<0.)THEN
3441 JFQ=-1
3442 ELSE
3443 JFQ=1
3444 ENDIF
3445 !
3446 IFPA(I,K,J)=IHE(J)+I+( JFP-1)/2
3447 IFQA(I,K,J)=IHE(J)+I+(-JFQ-1)/2
3448 !
3449 JFPA(I,K,J)=J+JFP
3450 JFQA(I,K,J)=J+JFQ
3451 !
3452 IFPF(I,K,J)=IHE(J)+I+(-JFP-1)/2
3453 IFQF(I,K,J)=IHE(J)+I+( JFQ-1)/2
3454 !
3455 JFPF(I,K,J)=J-JFP
3456 JFQF(I,K,J)=J-JFQ
3457 !
3458 !-----------------------------------------------------------------------
3459 IF(.NOT.HYDRO)THEN ! z currently not available for hydro=.true.
3460 DZA=(Z(IFPA(I,K,J),K,JFPA(I,K,J))-Z(I,K,J))*RDY
3461 DZB=(Z(IFQA(I,K,J),K,JFQA(I,K,J))-Z(I,K,J))*RDY
3462 !
3463 IF(ABS(DZA)>SLOPAC)THEN
3464 SSA=DZA*SPP
3465 IF(SSA>CRIT)THEN
3466 SPP=0. !spp*.1
3467 ENDIF
3468 ENDIF
3469 !
3470 IF(ABS(DZB)>SLOPAC)THEN
3471 SSB=DZB*SQP
3472 IF(SSB>CRIT)THEN
3473 SQP=0. !sqp*.1
3474 ENDIF
3475 ENDIF
3476 !
3477 ENDIF
3478 !-----------------------------------------------------------------------
3479 SPP=SPP*HTM(IFPA(I,K,J),K,JFPA(I,K,J))
3480 SQP=SQP*HTM(IFQA(I,K,J),K,JFQA(I,K,J))
3481 FPQ=SPP*SQP*HTM(I,K,J-2)*HTM(I-1,K,J) &
3482 & *HTM(I+1,K,J)*HTM(I,K,J+2)*0.25
3483 PP=ABS(SPP)
3484 QP=ABS(SQP)
3485 !
3486 AFP(I,K,J)=(((FF4*PP+FF3)*PP+FF2)*PP+FF1)*PP
3487 AFQ(I,K,J)=(((FF4*QP+FF3)*QP+FF2)*QP+FF1)*QP
3488 !
3489 Q1(I,K,J)=(Q (IFPA(I,K,J),K,JFPA(I,K,J))-Q (I,K,J))*PP &
3490 & +(Q (IFQA(I,K,J),K,JFQA(I,K,J))-Q (I,K,J))*QP &
3491 & +(Q (I,K,J-2)+Q (I,K,J+2) &
3492 & -Q (I-1,K,J)-Q (I+1,K,J))*FPQ &
3493 & +Q(I,K,J)
3494 !
3495 ENDDO
3496 ENDDO
3497 ENDDO
3498 !
3499 !-----------------------------------------------------------------------
3500 !*** ANTI-FILTERING STEP
3501 !-----------------------------------------------------------------------
3502 !
3503 DO K=KTS,KTE
3504 XSUMS(1,K)=0.
3505 XSUMS(2,K)=0.
3506 XSUMS(3,K)=0.
3507 XSUMS(4,K)=0.
3508 XSUMS(5,K)=0.
3509 XSUMS(6,K)=0.
3510 ENDDO
3511 !-----------------------------------------------------------------------
3512 !
3513 !*** ANTI-FILTERING LIMITERS
3514 !
3515 !-----------------------------------------------------------------------
3516 #if defined(BIT_FOR_BIT) && defined(DM_PARALLEL)
3517 DO N=1,6
3518 !
3519 !$omp parallel do &
3520 !$omp& private(i,j,k)
3521 DO J=JMS,JME
3522 DO K=KMS,KME
3523 DO I=IMS,IME
3524 XSUMS_L(I,K,J,N)=0.
3525 ENDDO
3526 ENDDO
3527 ENDDO
3528 !
3529 !$omp parallel do &
3530 !$omp& private(i,j,k)
3531 DO J=JDS,JDE
3532 DO K=KDS,KDE
3533 DO I=IDS,IDE
3534 XSUMS_G(I,K,J,N)=0.
3535 ENDDO
3536 ENDDO
3537 ENDDO
3538 !
3539 ENDDO
3540 !
3541 #endif
3542 !-----------------------------------------------------------------------
3543 DO 150 J=MYJS2,MYJE2
3544 DO 150 K=KTS,KTE
3545 DO 150 I=MYIS1,MYIE1
3546 !
3547 DVOLP=DVOL(I,K,J)
3548 Q1IJ =Q1(I,K,J)
3549 W1IJ =W1(I,K,J)
3550 E2IJ =E2(I,K,J)
3551 !
3552 HAFP=HTM(IFPF(I,K,J),K,JFPF(I,K,J))*AFP(I,K,J)
3553 HAFQ=HTM(IFQF(I,K,J),K,JFQF(I,K,J))*AFQ(I,K,J)
3554 !
3555 D2PQQ=(Q1(IFPA(I,K,J),K,JFPA(I,K,J))-Q1IJ &
3556 & -Q1IJ+Q1(IFPF(I,K,J),K,JFPF(I,K,J))) &
3557 & *HAFP &
3558 & +(Q1(IFQA(I,K,J),K,JFQA(I,K,J))-Q1IJ &
3559 & -Q1IJ+Q1(IFQF(I,K,J),K,JFQF(I,K,J))) &
3560 & *HAFQ
3561 !
3562 QSTIJ=Q1IJ-D2PQQ
3563 !
3564 Q00=Q (I ,K ,J)
3565 QP0=Q (IFPA(I,K,J),K,JFPA(I,K,J))
3566 Q0Q=Q (IFQA(I,K,J),K,JFQA(I,K,J))
3567 !
3568 QSTIJ=MAX(QSTIJ,MIN(Q00,QP0,Q0Q))
3569 QSTIJ=MIN(QSTIJ,MAX(Q00,QP0,Q0Q))
3570 !
3571 DQSTIJ=QSTIJ-Q(I,K,J)
3572 !
3573 DQST(I,K,J)=DQSTIJ
3574 !
3575 DQSTIJ=DQSTIJ*DVOLP
3576 !
3577 #if defined(BIT_FOR_BIT) && defined(DM_PARALLEL)
3578 DO N=1,6
3579 XSUMS_L(I,K,J,N)=0.
3580 ENDDO
3581 !
3582 IF(DQSTIJ>0.)THEN
3583 XSUMS_L(I,K,J,1)=DQSTIJ
3584 ELSE
3585 XSUMS_L(I,K,J,2)=DQSTIJ
3586 ENDIF
3587 !
3588 #else
3589 IF(DQSTIJ>0.)THEN
3590 XSUMS(1,K)=XSUMS(1,K)+DQSTIJ
3591 ELSE
3592 XSUMS(2,K)=XSUMS(2,K)+DQSTIJ
3593 ENDIF
3594 !
3595 #endif
3596 !
3597 150 CONTINUE
3598 !
3599 !-----------------------------------------------------------------------
3600 #if defined(BIT_FOR_BIT) && defined(DM_PARALLEL)
3601 DO N=1,6
3602 CALL WRF_PATCH_TO_GLOBAL_REAL( XSUMS_L(IMS,KMS,JMS,N) &
3603 &, XSUMS_G(1,1,1,N),DOMDESC &
3604 &, 'xyz','xzy' &
3605 &, IDS,IDE,KDS,KDE,JDS,JDE &
3606 &, IMS,IME,KMS,KME,JMS,JME &
3607 &, ITS,ITE,KTS,KTE,JTS,JTE )
3608 ENDDO
3609 !
3610 GSUMS=0.
3611 !
3612 IF(WRF_DM_ON_MONITOR())THEN
3613 DO N=1,6
3614 !$omp parallel do &
3615 !$omp& private(i,j,k)
3616 DO J=JDS,JDE
3617 DO K=KDS,KDE
3618 DO I=IDS,IDE
3619 GSUMS(N,K)=GSUMS(N,K)+XSUMS_G(I,K,J,N)
3620 ENDDO
3621 ENDDO
3622 ENDDO
3623 ENDDO
3624 ENDIF
3625
3626 CALL WRF_DM_BCAST_BYTES(GSUMS,2*RWORDSIZE*6*(KDE-KDS+1) )
3627
3628 #else
3629 !-----------------------------------------------------------------------
3630 !
3631 !-----------------------------------------------------------------------
3632 !*** GLOBAL REDUCTION
3633 !-----------------------------------------------------------------------
3634 !
3635 # ifdef DM_PARALLEL
3636 CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP)
3637 CALL MPI_ALLREDUCE(XSUMS,GSUMS,6*(KTE-KTS+1) &
3638 & ,MPI_DOUBLE_PRECISION,MPI_SUM &
3639 & ,MPI_COMM_COMP,IRECV)
3640 # else
3641 GSUMS=XSUMS
3642 # endif
3643 #endif
3644 !
3645 !-----------------------------------------------------------------------
3646 !*** END OF GLOBAL REDUCTION
3647 !-----------------------------------------------------------------------
3648 !
3649 ! if(mype==0)then
3650 ! if(ntsd==0)then
3651 !! call int_get_fresh_handle(nunit)
3652 !! close(nunit)
3653 ! nunit=56
3654 ! open(unit=nunit,file='gsums',form='unformatted',iostat=ier)
3655 ! endif
3656 ! endif
3657 DO K=KTS,KTE
3658 ! if(mype==0)then
3659 ! write(nunit)(gsums(i,k),i=1,6)
3660 ! endif
3661 !
3662 !-----------------------------------------------------------------------
3663 SUMPQ=GSUMS(1,K)
3664 SUMNQ=GSUMS(2,K)
3665 !
3666 !-----------------------------------------------------------------------
3667 !*** FIRST MOMENT CONSERVING FACTOR
3668 !-----------------------------------------------------------------------
3669 !
3670 IF(SUMPQ>1.)THEN
3671 RFACQK=-SUMNQ/SUMPQ
3672 ELSE
3673 RFACQK=1.
3674 ENDIF
3675 !
3676 IF(RFACQK<CONSERVE_MIN.OR.RFACQK>CONSERVE_MAX)RFACQK=1.
3677 !
3678 RFACQ(K)=RFACQK
3679 !
3680 ENDDO
3681 ! if(mype==0.and.ntsd==181)close(nunit)
3682 !
3683 !-----------------------------------------------------------------------
3684 !*** IMPOSE CONSERVATION ON ANTI-FILTERING
3685 !-----------------------------------------------------------------------
3686 !$omp parallel do &
3687 !$omp& private(dqstij,i,j,k,rfacqk,rfqij)
3688 DO J=MYJS2,MYJE2
3689 DO K=KTS,KTE
3690 RFACQK=RFACQ(K)
3691 IF(RFACQK<1.)THEN
3692 DO I=MYIS1,MYIE1
3693 DQSTIJ=DQST(I,K,J)
3694 RFQIJ=HBM2(I,J)*(RFACQK-1.)+1.
3695 IF(DQSTIJ>=0.)DQSTIJ=DQSTIJ*RFQIJ
3696 Q(I,K,J)=Q(I,K,J)+DQSTIJ
3697 ENDDO
3698 ELSE
3699 DO I=MYIS1,MYIE1
3700 DQSTIJ=DQST(I,K,J)
3701 RFQIJ=HBM2(I,J)*(RFACQK-1.)+1.
3702 IF(DQSTIJ<0.)DQSTIJ=DQSTIJ/RFQIJ
3703 Q(I,K,J)=Q(I,K,J)+DQSTIJ
3704 ENDDO
3705 ENDIF
3706 ENDDO
3707 ENDDO
3708 !-----------------------------------------------------------------------
3709 !$omp parallel do &
3710 !$omp& private(i,j,k)
3711 DO J=MYJS,MYJE
3712 DO K=KTS,KTE
3713 DO I=MYIS,MYIE
3714 ! SCAL(I,K,J,L)=MAX(Q (I,K,J),EPSILSCALAR)*HTM(I,K,J)
3715 SCAL(I,K,J,L)=Q (I,K,J)*HTM(I,K,J)
3716 ENDDO
3717 ENDDO
3718 ENDDO
3719
3720 ENDDO SCALAR_LOOP
3721 !-----------------------------------------------------------------------
3722 END SUBROUTINE HAD2_SCAL
3723 !-----------------------------------------------------------------------
3724 !-----------------------------------------------------------------------
3725 END MODULE MODULE_ADVECTION
3726 !-----------------------------------------------------------------------
3727