Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

module_PHYSICS_CALLS.F @ 1

Last change on this file since 1 was 1, checked in by lfita, 10 years ago

-- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

File size: 115.7 KB

Line
1	!-----------------------------------------------------------------------
2	!
3	!NCEP_MESO:MODEL_LAYER: PHYSICS
4	!
5	!-----------------------------------------------------------------------
6	#include "nmm_loop_basemacros.h"
7	#include "nmm_loop_macros.h"
8	!-----------------------------------------------------------------------
9	!
10	MODULE MODULE_PHYSICS_CALLS
11	!
12	!-----------------------------------------------------------------------
13	USE MODULE_DOMAIN
14	USE MODULE_DM
15	USE MODULE_CONFIGURE
16	USE MODULE_TILES
17	USE MODULE_STATE_DESCRIPTION,ONLY : P_QV,P_QC,P_QR,P_QI,P_QS,P_QG,P_QNI,P_QNR
18	USE MODULE_MODEL_CONSTANTS
19	USE MODULE_RA_GFDLETA,ONLY : CAL_MON_DAY,ZENITH
20	USE MODULE_RADIATION_DRIVER
21	USE MODULE_SF_MYJSFC
22	USE MODULE_SURFACE_DRIVER
23	USE MODULE_PBL_DRIVER
24	USE MODULE_GWD
25	USE MODULE_CU_BMJ
26	USE MODULE_CUMULUS_DRIVER
27	USE MODULE_MP_ETANEW
28	USE MODULE_MICROPHYSICS_DRIVER
29	USE MODULE_MICROPHYSICS_ZERO_OUT
30	!-----------------------------------------------------------------------
31	!
32	CONTAINS
33	!
34	!-----------------------------------------------------------------------
35	!***********************************************************************
36	SUBROUTINE RADIATION(NTSD,DT,JULDAY,JULYR,XTIME,JULIAN &
37	& ,IHRST,NPHS,GLAT,GLON &
38	& ,NRADS,NRADL &
39	& ,DETA1,DETA2,AETA1,AETA2,ETA1,ETA2,PDTOP,PT &
40	& ,PD,RES,PINT,T,Q,MOIST,THS,ALBEDO,EPSR &
41	& ,F_ICE,F_RAIN &
42	#ifdef WRF_CHEM
43	& ,GD_CLOUD,GD_CLOUD2 &
44	#endif
45	& ,SM,HBM2,CLDFRA,N_MOIST,RESTRT &
46	& ,RLWTT,RSWTT,RLWIN,RSWIN,RSWINC,RSWOUT &
47	& ,RLWTOA,RSWTOA,CZMEAN &
48	& ,CFRACL,CFRACM,CFRACH,SIGT4 &
49	& ,ACFRST,NCFRST,ACFRCV,NCFRCV &
50	& ,CUPPT,VEGFRC,SNOW,HTOP,HBOT &
51	& ,Z,SICE,NUM_AEROSOLC,NUM_OZMIXM &
52	& ,GRID,CONFIG_FLAGS &
53	& ,RTHRATEN &
54	#ifdef WRF_CHEM
55	& ,PM2_5_DRY, PM2_5_WATER, PM2_5_DRY_EC &
56	& ,TAUAER1, TAUAER2, TAUAER3, TAUAER4 &
57	& ,GAER1, GAER2, GAER3, GAER4 &
58	& ,WAER1, WAER2, WAER3, WAER4 &
59	#endif
60	& ,IDS,IDE,JDS,JDE,KDS,KDE &
61	& ,IMS,IME,JMS,JME,KMS,KME &
62	& ,ITS,ITE,JTS,JTE,KTS,KTE)
63	!* NOTE *
64	! RLWIN - downward longwave at the surface (=TOTLWDN, now a local array)
65	! RSWIN - downward shortwave at the surface (=TOTSWDN, now a local array)
66	! RSWINC - CLEAR-SKY downward shortwave at the surface (=TOTSWDNC, new for AQ)
67	!***********************************************************************
68	!$$$ SUBPROGRAM DOCUMENTATION BLOCK
69	! . . .
70	! SUBPROGRAM: RADIATION RADIATION OUTER DRIVER
71	! PRGRMMR: BLACK ORG: W/NP22 DATE: 2002-06-04
72	!
73	! ABSTRACT:
74	! RADIATION SERVES AS THE INTERFACE BETWEEN THE NCEP NONHYDROSTATIC
75	! MESOSCALE MODEL AND THE WRF RADIATION DRIVER.
76	!
77	! PROGRAM HISTORY LOG:
78	! 02-06-04 BLACK - ORIGINATOR
79	! 02-09-09 WOLFE - CONVERTING TO GLOBAL INDEXING
80	! 04-11-18 BLACK - THREADED
81	! 05-12-15 BLACK - CONVERTED FROM IKJ TO IJK
82	!
83	! USAGE: CALL RADIATION FROM SOLVE_NMM
84	!
85	! ATTRIBUTES:
86	! LANGUAGE: FORTRAN 90
87	! MACHINE : IBM
88	!$$$
89	!-----------------------------------------------------------------------
90	!
91	IMPLICIT NONE
92	!
93	!-----------------------------------------------------------------------
94	!
95	INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
96	& ,IMS,IME,JMS,JME,KMS,KME &
97	& ,ITS,ITE,JTS,JTE,KTS,KTE &
98	& ,IHRST,JULDAY,JULYR &
99	& ,N_MOIST,NPHS,NRADL,NRADS,NTSD &
100	& ,NUM_AEROSOLC,NUM_OZMIXM
101	!
102	INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: NCFRCV,NCFRST
103	!
104	REAL,INTENT(IN) :: DT,PDTOP,PT,XTIME,JULIAN
105	!
106	REAL,DIMENSION(KMS:KME-1),INTENT(IN) :: AETA1,AETA2,DETA1,DETA2
107	!
108	REAL,DIMENSION(KMS:KME),INTENT(IN) :: ETA1,ETA2
109	!
110	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: ALBEDO &
111	& ,EPSR,GLAT,GLON &
112	& ,HBM2 &
113	& ,PD,RES,SICE,SM &
114	& ,SNOW,THS,VEGFRC
115	!
116	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: CUPPT
117
118	!
119	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: Q,T,Z
120	!
121	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: F_ICE & !<--- Used only with physics (IKJ)
122	& ,F_RAIN
123	!
124	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: RTHRATEN !<--- Used only with physics (IKJ)
125	!
126	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME,N_MOIST) &
127	,INTENT(INOUT) :: MOIST
128	!
129	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: ACFRCV,ACFRST &
130	& ,HBOT,HTOP &
131	& ,RLWIN,RLWTOA &
132	& ,RSWIN,RSWOUT &
133	& ,RSWINC,RSWTOA
134	!
135	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: PINT &
136	& ,RLWTT &
137	& ,RSWTT
138	!
139	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: CFRACH,CFRACL &
140	& ,CFRACM,CZMEAN &
141	& ,SIGT4
142	!
143	#ifdef WRF_CHEM
144	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME ),INTENT(IN) :: & !<--- Used only with physics (IKJ)
145	& GAER1,GAER2,GAER3,GAER4, &
146	& GD_CLOUD,GD_CLOUD2, &
147	& PM2_5_DRY,PM2_5_WATER,PM2_5_DRY_EC, &
148	& TAUAER1,TAUAER2,TAUAER3,TAUAER4, &
149	& WAER1,WAER2,WAER3,WAER4
150	#endif
151	!
152	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: CLDFRA
153	!
154	LOGICAL,INTENT(IN) :: RESTRT
155	!
156	TYPE(DOMAIN),TARGET :: GRID
157	!
158	TYPE(GRID_CONFIG_REC_TYPE),INTENT(IN) :: CONFIG_FLAGS
159	!
160	!-----------------------------------------------------------------------
161	!***
162	!*** LOCAL VARIABLES
163	!***
164	!-----------------------------------------------------------------------
165	INTEGER :: I,ICLOUD,IENDX,II,ISTAT,J,JDAY,JMONTH,K,KMNTH,N,NRAD
166	!
167	INTEGER,DIMENSION(3) :: IDAT
168	INTEGER,DIMENSION(12) :: MONTH=(/31,28,31,30,31,30,31,31 &
169	& ,30,31,30,31/)
170	!
171	REAL :: CAPA,DAYI,DPL,FICE,FRAIN,GMT,HOUR,PLYR,PSFC &
172	& ,QI,QR,QW,RADT,TIMES,WC,TDUM
173	!
174	REAL,DIMENSION(KMS:KME-1) :: QL,TL
175	!
176	REAL,DIMENSION(IMS:IME,JMS:JME) :: CUPPTR,CZEN,HBOTR,HTOPR &
177	& ,PDSL,REXNSFC,SWNETDN &
178	& ,TOT,TOTLWDN,TOTSWDN,TOTSWDNC &
179	& ,TSFC,XLAND,XLAT,XLON
180	!
181	!
182	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: CLFR,DZ & !<--- Used only with physics (IKJ)
183	& ,P8W,P_PHY,PI_PHY &
184	& ,RR,T8W &
185	& ,THRATENLW,THRATENSW &
186	& ,TH_PHY,T_PHY,Z_PHY
187	!
188	REAL,DIMENSION(:,:,:,:),ALLOCATABLE :: MOIST_TRANS
189	!
190	LOGICAL :: WARM_RAIN
191	!
192	!-----------------------------------------------------------------------
193	!***********************************************************************
194	!-----------------------------------------------------------------------
195	!*****
196	!***** NOTE: THIS IS HARDWIRED FOR CALLS TO LONGWAVE AND SHORTWAVE
197	!***** AT EQUAL INTERVALS
198	!*****
199	!-----------------------------------------------------------------------
200	!
201	NRAD=NRADS
202	RADT=DT*NRADS/60.
203	!
204	!-----------------------------------------------------------------------
205	!
206	ALLOCATE(MOIST_TRANS(IMS:IME,KMS:KME,JMS:JME,N_MOIST),STAT=ISTAT)
207	!
208	!-----------------------------------------------------------------------
209	!
210	CAPA=R_D/CP
211	!
212	!-----------------------------------------------------------------------
213	!
214	!$omp parallel do &
215	!$omp& private(i,j)
216	DO J=MYJS2,MYJE2
217	DO I=MYIS1,MYIE1
218	!
219	PDSL(I,J)=PD(I,J)*RES(I,J)
220	P8W(I,KTE+1,J)=PT
221	XLAT(I,J)=GLAT(I,J)/DEGRAD
222	XLON(I,J)=GLON(I,J)/DEGRAD
223	XLAND(I,J)=SM(I,J)+1.
224	PSFC=PD(I,J)+PDTOP+PT
225	REXNSFC(I,J)=(PSFC1.E-5)*CAPA
226	TSFC(I,J)=THS(I,J)*REXNSFC(I,J)
227	T8W(I,KTS,J)=TSFC(I,J)
228	P8W(I,KTS,J)=ETA1(KTS)PDTOP+ETA2(KTS)PDSL(I,J)+PT
229	Z_PHY(I,KTS,J)=Z(I,J,KTS)
230	ENDDO
231	ENDDO
232	!
233	!-----------------------------------------------------------------------
234	!*** FILL THE SINGLE-COLUMN INPUT
235	!-----------------------------------------------------------------------
236	!
237	!$omp parallel do &
238	!$omp& private(dpl,i,j,k,plyr,ql,qr,tl)
239	DO J=MYJS2,MYJE2
240	DO I=MYIS1,MYIE1
241	DO K=KTS,KTE
242	DPL=DETA1(K)PDTOP+DETA2(K)PDSL(I,J)
243	QL(K)=MAX(Q(I,J,K),EPSQ)
244	PLYR=AETA1(K)PDTOP+AETA2(K)PDSL(I,J)+PT
245	TL(K)=T(I,J,K)
246	!
247	RR(I,K,J)=PLYR/(R_DTL(K)(1.+P608*QL(K)))
248	T_PHY(I,K,J)=TL(K)
249	TH_PHY(I,K,J)=TL(K)(1.E5/PLYR)*CAPA
250	P8W(I,K+1,J)=ETA1(K+1)PDTOP+ETA2(K+1)PDSL(I,J)+PT
251	P_PHY(I,K,J)=PLYR
252	PI_PHY(I,K,J)=(PLYR1.E-5)*CAPA
253	DZ(I,K,J)=TL(K)(P608QL(K)+1.)*R_D &
254	& *(P8W(I,K,J)-P8W(I,K+1,J)) &
255	& /(P_PHY(I,K,J)*G)
256	!
257	RTHRATEN(I,K,J)=0.
258	THRATENLW(I,K,J)=0.
259	THRATENSW(I,K,J)=0.
260	! PM2_5_DRY(I,K,J)=0.
261	! PM2_5_WATER(I,K,J)=0.
262
263	ENDDO
264	!
265	DO K=KTS+1,KTE
266	T8W(I,K,J)=0.5*(TL(K-1)+TL(K))
267	ENDDO
268	! T8W(I,KTE+1,J)=-1.E20
269	! For RRTM
270	T8W(I,KTE+1,J)=T8W(I,KTE,J) + 0.5*(T8W(I,KTE,J)-T8W(I,KTE-1,J))
271	!
272	ENDDO
273	ENDDO
274	!
275	ICLOUD=999
276	!
277	GMT=REAL(IHRST)
278	!
279	!$omp parallel do &
280	!$omp& private(i,j,k)
281	DO K=KMS,KME
282	DO J=JMS,JME
283	DO I=IMS,IME
284	CLDFRA(I,J,K)=0.
285	ENDDO
286	ENDDO
287	ENDDO
288	!
289	!$omp parallel do &
290	!$omp& private(i,j)
291	DO J=JMS,JME
292	DO I=IMS,IME
293	CFRACH(I,J)=0.
294	CFRACL(I,J)=0.
295	CFRACM(I,J)=0.
296	CZMEAN(I,J)=0.
297	SIGT4(I,J)=0.
298	TOTSWDN(I,J)=0. ! TOTAL (clear+cloudy sky) shortwave down at the surface
299	TOTSWDNC(I,J)=0. ! CLEAR SKY shortwave down at the surface
300	SWNETDN(I,J)=0. ! Net (down - up) total (clear+cloudy sky) shortwave at the surface
301	TOTLWDN(I,J)=0. ! Total longwave down at the surface
302	CUPPTR(I,J)=CUPPT(I,J) ! Temporary array set to zero in radiation
303	HTOPR(I,J) =0.
304	HBOTR(I,J) =0.
305	!
306	!-- NOTE: HBOTR, HTOPR are passed into radiation and set equal to HBOT, HTOP. HBOT, HTOP are
307	! reset to clear sky values to be used by the ARW. At the bottom of this subroutine,
308	! HBOT, HTOP are re-defined again to values stored in HBOTR, HTOPR. HBOT, HTOP are
309	! reset to clear sky values after the call to radiation and after the top of the hour
310	! in subroutine CUCNVC below.
311	!
312	ENDDO
313	ENDDO
314	!
315	!-----------------------------------------------------------------------
316	!*** TRANSPOSE THE MOIST ARRAY (IJK) FOR THE PHYSICS (IKJ).
317	!*** REMEMBER THAT MOIST AND MOIST_TRANS ARE ONLY USED WITH
318	!*** THE PHYSICS AND THUS THE P_QV SLOT (=2) IS MIXING RATIO,
319	!*** NOT SPECIFIC HUMIDITY.
320	!-----------------------------------------------------------------------
321	!
322	DO N=1,N_MOIST
323	!$omp parallel do &
324	!$omp& private(i,j,k)
325	DO K=KMS,KME
326	DO J=JMS,JME
327	DO I=IMS,IME
328	MOIST_TRANS(I,K,J,N)=MOIST(I,J,K,N)
329	ENDDO
330	ENDDO
331	ENDDO
332	ENDDO
333	!
334	!-----------------------------------------------------------------------
335	!
336	!*** CALL THE INNER DRIVER.
337	!
338	!-----------------------------------------------------------------------
339	!
340	CALL SET_TILES(GRID,IDS+1,IDE-1,JDS+2,JDE-2,ITS,ITE,JTS,JTE)
341	!
342	CALL RADIATION_DRIVER( &
343	& IDS=IDS,IDE=IDE,JDS=JDS,JDE=JDE,KDS=KDS,KDE=KDE &
344	& ,IMS=IMS,IME=IME,JMS=JMS,JME=JME,KMS=KMS,KME=KME &
345	& ,I_START=GRID%I_START,I_END=GRID%I_END &
346	& ,J_START=GRID%J_START,J_END=GRID%J_END &
347	& ,KTS=KTS,KTE=KTE,NUM_TILES=GRID%NUM_TILES &
348	& ,ITIMESTEP=NTSD,DT=DT &
349	#ifdef WRF_CHEM
350	& ,CU_RAD_FEEDBACK=config_flags%cu_rad_feedback &
351	& ,AER_RA_FEEDBACK=config_flags%aer_ra_feedback &
352	& ,PM2_5_DRY=pm2_5_dry,PM2_5_WATER=pm2_5_water &
353	& ,PM2_5_DRY_EC=pm2_5_dry_ec &
354	& ,TAUAER300=tauaer1,TAUAER400=tauaer2,TAUAER600=tauaer3,TAUAER999=tauaer4 & ! jcb
355	& ,GAER300=gaer1,GAER400=gaer2,GAER600=gaer3,GAER999=gaer4 & ! jcb
356	& ,WAER300=waer1,WAER400=waer2,WAER600=waer3,WAER999=waer4 & ! jcb
357	& ,QC_ADJUST=GD_CLOUD,QI_ADJUST=GD_CLOUD2 &
358	#endif
359	& ,RTHRATENLW=THRATENLW,RTHRATENSW=THRATENSW &
360	& ,RTHRATEN=RTHRATEN &
361	& ,CEN_LAT=grid%cen_lat &
362	& ,GLW=TOTLWDN,GSW=SWNETDN,SWDOWN=TOTSWDN &
363	& ,XLAT=XLAT,XLONG=XLON,ALBEDO=ALBEDO,EMISS=EPSR &
364	& ,XICE=SICE,XLAND=XLAND,Z=Z,TSK=TSFC &
365	& ,N_AEROSOLC=NUM_AEROSOLC,PAERLEV=GRID%PAERLEV &
366	& ,CAM_ABS_DIM1=GRID%CAM_ABS_DIM1 &
367	& ,CAM_ABS_DIM2=GRID%CAM_ABS_DIM2 &
368	& ,CAM_ABS_FREQ_S=GRID%CAM_ABS_FREQ_S &
369	& ,LEVSIZ=GRID%LEVSIZ,N_OZMIXM=NUM_OZMIXM &
370	& ,HTOP=HTOP,HBOT=HBOT,CUPPT=CUPPTR &
371	& ,HTOPR=HTOPR,HBOTR=HBOTR &
372	& ,VEGFRA=VEGFRC,SNOW=SNOW &
373	& ,RHO=RR,P8W=P8W,P=P_PHY,PI=PI_PHY &
374	& ,DZ8W=DZ,T=T_PHY,T8W=T8W,GMT=GMT &
375	& ,JULDAY=JULDAY,JULYR=JULYR,NPHS=NPHS &
376	& ,JULIAN=JULIAN,XTIME=XTIME &
377	& ,LW_PHYSICS=CONFIG_FLAGS%RA_LW_PHYSICS &
378	& ,SW_PHYSICS=CONFIG_FLAGS%RA_SW_PHYSICS &
379	& ,RADT=RADT,RA_CALL_OFFSET=GRID%RA_CALL_OFFSET &
380	& ,STEPRA=NRAD,ICLOUD=ICLOUD &
381	& ,WARM_RAIN=WARM_RAIN &
382	& ,SWDOWNC=TOTSWDNC,CLDFRA=CLFR &
383	& ,RSWTOA=RSWTOA,RLWTOA=RLWTOA &
384	& ,CZMEAN=CZMEAN,CFRACL=CFRACL &
385	& ,CFRACM=CFRACM,CFRACH=CFRACH &
386	& ,ACFRST=ACFRST,NCFRST=NCFRST &
387	& ,ACFRCV=ACFRCV,NCFRCV=NCFRCV &
388	& ,F_ICE_PHY=F_ICE,F_RAIN_PHY=F_RAIN &
389	& ,QV=MOIST_TRANS(IMS,KMS,JMS,P_QV),F_QV=F_QV &
390	& ,QC=MOIST_TRANS(IMS,KMS,JMS,P_QC),F_QC=F_QC &
391	& ,QR=MOIST_TRANS(IMS,KMS,JMS,P_QR),F_QR=F_QR &
392	& ,QI=MOIST_TRANS(IMS,KMS,JMS,P_QI),F_QI=F_QI &
393	& ,QS=MOIST_TRANS(IMS,KMS,JMS,P_QS),F_QS=F_QS &
394	& ,QG=MOIST_TRANS(IMS,KMS,JMS,P_QG),F_QG=F_QG )
395
396	!
397	!-----------------------------------------------------------------------
398	!
399	!*** UPDATE FLUXES AND TEMPERATURE TENDENCIES.
400	!
401	!-----------------------------------------------------------------------
402	!*** SHORTWAVE
403	!-----------------------------------------------------------------------
404	!
405	!-----------------------------------------------------------------------
406	nrads_block: IF(MOD(NTSD,NRADS)==0)THEN
407	!-----------------------------------------------------------------------
408	!
409	IF(CONFIG_FLAGS%RA_SW_PHYSICS/=GFDLSWSCHEME)THEN
410	!
411	!-----------------------------------------------------------------------
412	!*** COMPUTE CZMEAN FOR NON-GFDL SHORTWAVE
413	!-----------------------------------------------------------------------
414	!
415	!$omp parallel do &
416	!$omp& private(i,j)
417	DO J=MYJS,MYJE
418	DO I=MYIS,MYIE
419	CZMEAN(I,J)=0.
420	TOT(I,J)=0.
421	ENDDO
422	ENDDO
423	!
424	CALL CAL_MON_DAY(JULDAY,JULYR,JMONTH,JDAY)
425	IDAT(1)=JMONTH
426	IDAT(2)=JDAY
427	IDAT(3)=JULYR
428	!
429	DO II=0,NRADS,NPHS
430	TIMES=NTSDDT+IIDT
431	CALL ZENITH(TIMES,DAYI,HOUR,IDAT,IHRST,GLON,GLAT,CZEN &
432	& ,MYIS,MYIE,MYJS,MYJE &
433	& ,IDS,IDE,JDS,JDE,KDS,KDE &
434	& ,IMS,IME,JMS,JME,KMS,KME &
435	& ,ITS,ITE,JTS,JTE,KTS,KTE)
436	!
437	!$omp parallel do &
438	!$omp& private(i,j)
439	DO J=MYJS,MYJE
440	DO I=MYIS,MYIE
441	IF(CZEN(I,J)>0.)THEN
442	CZMEAN(I,J)=CZMEAN(I,J)+CZEN(I,J)
443	TOT(I,J)=TOT(I,J)+1.
444	ENDIF
445	ENDDO
446	ENDDO
447	!
448	ENDDO
449	!
450	!$omp parallel do &
451	!$omp& private(i,j)
452	DO J=MYJS,MYJE
453	DO I=MYIS,MYIE
454	IF(TOT(I,J)>0.)CZMEAN(I,J)=CZMEAN(I,J)/TOT(I,J)
455	ENDDO
456	ENDDO
457	!
458	!-----------------------------------------------------------------------
459	!*** COMPUTE TOTAL SFC SHORTWAVE DOWN FOR NON-GFDL SCHEMES
460	!-----------------------------------------------------------------------
461	!
462	!$omp parallel do &
463	!$omp& private(i,j)
464	DO J=MYJS2,MYJE2
465	DO I=MYIS1,MYIE1
466	!
467	IF(HBM2(I,J)>0.5)THEN
468	TOTSWDN(I,J)=SWNETDN(I,J)/(1.-ALBEDO(I,J))
469	!
470	!--- No value currently available for clear-sky solar fluxes from
471	! non GFDL schemes, though it's needed for air quality forecasts.
472	! For the time being, set to the total downward solar fluxes.
473	!
474	TOTSWDNC(I,J)=TOTSWDN(I,J)
475	ENDIF
476	!
477	ENDDO
478	ENDDO
479	!
480	ENDIF !End non-GFDL block
481	!-----------------------------------------------------------------------
482	!
483	!$omp parallel do &
484	!$omp& private(i,iendx,j)
485	DO J=MYJS2,MYJE2
486	IENDX=MYIE1
487	IF(MOD(J,2)==0.AND.ITE==IDE)IENDX=IENDX-1
488	DO I=MYIS1,IENDX
489	!
490	RSWIN(I,J)=TOTSWDN(I,J)
491	RSWINC(I,J)=TOTSWDNC(I,J)
492	RSWOUT(I,J)=TOTSWDN(I,J)-SWNETDN(I,J)
493	!
494	ENDDO
495	ENDDO
496	!
497	!$omp parallel do &
498	!$omp& private(i,iendx,j,k)
499	DO J=MYJS2,MYJE2
500	IENDX=MYIE1
501	IF(MOD(J,2)==0.AND.ITE==IDE)IENDX=IENDX-1
502	DO I=MYIS1,IENDX
503	DO K=KTS,KTE
504	RSWTT(I,J,K)=THRATENSW(I,K,J)*PI_PHY(I,K,J)
505	ENDDO
506	!
507	ENDDO
508	ENDDO
509	!
510	ENDIF nrads_block
511	!
512	!-----------------------------------------------------------------------
513	!*** LONGWAVE
514	!-----------------------------------------------------------------------
515	!
516	nradl_block: IF(MOD(NTSD,NRADL)==0)THEN
517	!
518	!$omp parallel do &
519	!$omp& private(i,iendx,j)
520	DO J=MYJS2,MYJE2
521	IENDX=MYIE1
522	IF(MOD(J,2)==0.AND.ITE==IDE)IENDX=IENDX-1
523	DO I=MYIS1,IENDX
524	!
525	IF(HBM2(I,J)>0.5)THEN
526	TDUM=T(I,J,KTS)
527	SIGT4(I,J)=STBOLTTDUMTDUMTDUMTDUM
528	RLWIN(I,J)=TOTLWDN(I,J)
529	ENDIF
530	!
531	ENDDO
532	ENDDO
533	!
534	!$omp parallel do &
535	!$omp& private(i,iendx,j,k)
536	DO J=MYJS2,MYJE2
537	IENDX=MYIE1
538	IF(MOD(J,2)==0.AND.ITE==IDE)IENDX=IENDX-1
539	!
540	DO K=KTS,KTE
541	DO I=MYIS1,IENDX
542	IF(HBM2(I,J)>0.5)THEN
543	RLWTT(I,J,K)=THRATENLW(I,K,J)*PI_PHY(I,K,J)
544	ENDIF
545	ENDDO
546	ENDDO
547	!
548	ENDDO
549	!
550	ENDIF nradl_block
551	!
552	!-----------------------------------------------------------------------
553	!*** STORE 3D CLOUD FRACTIONS.
554	!-----------------------------------------------------------------------
555	!
556	!$omp parallel do &
557	!$omp& private(i,iendx,j,k)
558	DO K=KTS,KTE
559	DO J=MYJS2,MYJE2
560	IENDX=MYIE1
561	IF(MOD(J,2)==0.AND.ITE==IDE)IENDX=IENDX-1
562	DO I=MYIS1,IENDX
563	CLDFRA(I,J,K)=CLFR(I,K,J)
564	ENDDO
565	ENDDO
566	ENDDO
567	!
568	!-----------------------------------------------------------------------
569	!*** RESET THE DIAGNOSTIC CONVECTIVE CLOUD TOPS/BOTTOMS AFTER
570	!*** EACH RADIATION CALL.
571	!-----------------------------------------------------------------------
572	!
573	!$omp parallel do &
574	!$omp& private(i,iendx,j)
575	!if (config_flags%ra_sw_physics/=hwrfswscheme.and.config_flags%ra_lw_physics/=hwrflwscheme)then
576	DO J=MYJS2,MYJE2
577	IENDX=MYIE1
578	IF(MOD(J,2)==0.AND.ITE==IDE)IENDX=IENDX-1
579	DO I=MYIS1,IENDX
580	HBOT(I,J)=HBOTR(I,J)
581	HTOP(I,J)=HTOPR(I,J)
582	CUPPT(I,J)=CUPPTR(I,J)
583	ENDDO
584	ENDDO
585	!endif
586	!
587	!-----------------------------------------------------------------------
588	!*** ZERO OUT BOUNDARY ROWS.
589	!-----------------------------------------------------------------------
590	!
591	DO J=JTS,JTE
592	DO I=ITS,ITE
593	IF(HBM2(I,J)<0.5)THEN
594	ACFRST(I,J)=0.
595	ACFRCV(I,J)=0.
596	CFRACL(I,J)=0.
597	CFRACM(I,J)=0.
598	CFRACH(I,J)=0.
599	RSWTOA(I,J)=0.
600	RLWTOA(I,J)=0.
601	ENDIF
602	ENDDO
603	ENDDO
604	!
605	!
606	!-----------------------------------------------------------------------
607	!*** UPDATE THE PROGNOSTIC MOIST ARRAY.
608	!-----------------------------------------------------------------------
609	!
610	DO N=2,N_MOIST
611	!$omp parallel do &
612	!$omp& private(i,j,k)
613	DO J=JMS,JME
614	DO K=KMS,KME
615	DO I=IMS,IME
616	MOIST(I,J,K,N)=MOIST_TRANS(I,K,J,N)
617	ENDDO
618	ENDDO
619	ENDDO
620	ENDDO
621	!
622	DEALLOCATE(MOIST_TRANS,STAT=ISTAT)
623	!
624	!-----------------------------------------------------------------------
625	!
626	END SUBROUTINE RADIATION
627	!
628	!-----------------------------------------------------------------------
629	!***********************************************************************
630	!-----------------------------------------------------------------------
631	SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT &
632	& ,N_MOIST,NSOIL,SLDPTH,DZSOIL &
633	& ,DETA1,DETA2,AETA1,AETA2,ETA1,ETA2,PDTOP,PT &
634	& ,SM,HBM2,VBM2,DX_ARRAY,DFRLG &
635	& ,CZEN,CZMEAN,SIGT4,RLWIN,RSWIN,RADOT &
636	!- RLWIN/RSWIN - downward longwave/shortwave at the surface (also TOTLWDN/TOTSWDN in RADIATION)
637	& ,PD,RES,PINT,T,Q,CWM,F_ICE,F_RAIN,SR &
638	& ,Q2,U,V,THS,TSFC,SST,PREC,SNO &
639	& ,FIS,Z0,Z0BASE,USTAR,MIXHT,PBLH,LPBL,EL_MYJ &
640	& ,MOIST,RMOL,MOL &
641	& ,EXCH_H,EXCH_M,F,AKHS,AKMS,AKHS_OUT,AKMS_OUT &
642	& ,THZ0,QZ0,UZ0,VZ0,QS,MAVAIL &
643	& ,STC,SMC,CMC,SMSTAV,SMSTOT,SSROFF,BGROFF &
644	& ,IVGTYP,ISLTYP,VEGFRC,SHDMIN,SHDMAX,GRNFLX &
645	& ,SNOTIME &
646	& ,SFCEXC,ACSNOW,ACSNOM,SNOPCX,SICE,TG,SOILTB &
647	& ,ALBASE,MXSNAL,ALBEDO,SH2O,SI,EPSR,EMBCK &
648	& ,U10,V10,TH10,Q10,TSHLTR,QSHLTR,PSHLTR &
649	& ,T2,QSG,QVG,QCG,SOILT1,TSNAV,SMFR3D,KEEPFR3DFLAG &
650	& ,TWBS,QWBS,TAUX,TAUY,SFCSHX,SFCLHX,SFCEVP &
651	& ,POTEVP,POTFLX,SUBSHX &
652	& ,APHTIM,ARDSW,ARDLW,ASRFC &
653	& ,RSWOUT,RSWTOA,RLWTOA &
654	& ,ASWIN,ASWOUT,ASWTOA,ALWIN,ALWOUT,ALWTOA &
655	& ,UZ0H,VZ0H,DUDT,DVDT,UGWDsfc,VGWDsfc,SFENTH & ! GWD
656	& ,RTHBLTEN,RQVBLTEN &
657	& ,PCPFLG,DDATA & ! PRECIP ASSIM
658	& ,HSTDV,HCNVX,HASYW,HASYS,HASYSW,HASYNW,HLENW & ! GWD
659	& ,HLENS,HLENSW,HLENNW,HANGL,HANIS,HSLOP,HZMAX & ! GWD
660	& ,CROT,SROT & ! GWD
661	& ,DEW & ! RUC LSM
662	& ,GRID,CONFIG_FLAGS &
663	& ,IHE,IHW,IVE,IVW &
664	& ,DISHEAT &
665	& ,IDS,IDE,JDS,JDE,KDS,KDE &
666	& ,IMS,IME,JMS,JME,KMS,KME &
667	& ,ITS,ITE,JTS,JTE,KTS,KTE)
668	!***********************************************************************
669	!$$$ SUBPROGRAM DOCUMENTATION BLOCK
670	! . . .
671	! SUBPROGRAM: TURBL TURBULENCE OUTER DRIVER
672	! PRGRMMR: BLACK ORG: W/NP22 DATE: 02-04-19
673	!
674	! ABSTRACT:
675	! TURBL DRIVES THE TURBULENCE SCHEMES
676	!
677	! PROGRAM HISTORY LOG (with changes to called routines) :
678	! 95-03-15 JANJIC - ORIGINATOR OF THE SUBROUTINES CALLED
679	! BLACK & JANJIC - ORIGINATORS OF THE DRIVER
680	! 95-03-28 BLACK - CONVERSION FROM 1-D TO 2-D IN HORIZONTAL
681	! 96-03-29 BLACK - ADDED EXTERNAL EDGE; REMOVED SCRCH COMMON
682	! 96-07-19 MESINGER - ADDED Z0 EFFECTIVE
683	! 98-??-?? TUCCILLO - MODIFIED FOR CLASS VIII PARALLELISM
684	! 98-10-27 BLACK - PARALLEL CHANGES INTO MOST RECENT CODE
685	! 02-01-10 JANJIC - MOIST TURBULENCE (DRIVER, MIXLEN, VDIFH)
686	! 02-01-10 JANJIC - VERT. DIF OF Q2 INCREASED (Grenier & Bretherton)
687	! 02-02-02 JANJIC - NEW SFCDIF
688	! 02-04-19 BLACK - ORIGINATOR OF THIS OUTER DRIVER FOR WRF
689	! 02-05-03 JANJIC - REMOVAL OF SUPERSATURATION AT 2m AND 10m
690	! 04-11-18 BLACK - THREADED
691	! 05-12-15 BLACK - CONVERTED FROM IKJ TO IJK
692	! 07-05-15 FERRIER - ADDED GRAVITY WAVE DRAG (GWD) & MOUNTAIN BLOCKING
693	!
694	! USAGE: CALL TURBL FROM SOLVE_NMM
695	!
696	! ATTRIBUTES:
697	! LANGUAGE: FORTRAN 90
698	! MACHINE : IBM
699	!$$$
700	!-----------------------------------------------------------------------
701	!
702	IMPLICIT NONE
703	!
704	!-----------------------------------------------------------------------
705	!
706	#if (NMM_CORE==1)
707	LOGICAL,INTENT(IN) :: DISHEAT ! hwrf's doing
708	#endif
709	INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
710	& ,IMS,IME,JMS,JME,KMS,KME &
711	& ,ITS,ITE,JTS,JTE,KTS,KTE &
712	& ,N_MOIST,NPHS,NSOIL,NTSD
713	!
714	INTEGER, DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
715	!
716	INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: ISLTYP,IVGTYP
717	!
718	INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: LPBL
719	!
720	REAL,INTENT(IN) :: DT,PDTOP,PT
721	!
722	REAL,INTENT(IN) :: SFENTH
723	REAL,INTENT(INOUT) :: APHTIM,ARDSW,ARDLW,ASRFC
724	!
725	REAL,DIMENSION(KMS:KME-1),INTENT(IN) :: AETA1,AETA2,DETA1,DETA2
726	!
727	REAL,DIMENSION(KMS:KME),INTENT(IN) :: DFRLG,ETA1,ETA2
728	!
729	REAL,DIMENSION(NSOIL),INTENT(IN) :: DZSOIL,SLDPTH
730	!
731	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: CZEN,CZMEAN &
732	& ,DX_ARRAY &
733	& ,F,FIS,HBM2 &
734	& ,PD,RES &
735	& ,RLWIN,RLWTOA &
736	& ,RSWIN,RSWOUT,RSWTOA &
737	& ,SHDMIN,SHDMAX &
738	! & ,SICE,SIGT4,SM,SR & !Bandaid
739	& ,SIGT4 &
740	& ,HSTDV,HCNVX,HASYW,HASYS,HASYSW,HASYNW,HLENW & ! GWD
741	& ,HLENS,HLENSW,HLENNW,HANGL,HANIS,HSLOP,HZMAX & ! GWD
742	& ,CROT,SROT & ! GWD
743	& ,VBM2,VEGFRC
744	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: SST
745	!
746	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: SM,EPSR,SR & !Bandaid
747	,TG,SICE &
748	,EMBCK
749	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: ALBASE,MXSNAL
750	!
751	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: ACSNOM,ACSNOW &
752	& ,SNOTIME &
753	& ,AKHS,AKMS &
754	& ,ALBEDO &
755	& ,BGROFF,CMC &
756	& ,MAVAIL,MOL &
757	& ,MIXHT &
758	& ,PBLH,POTEVP &
759	& ,POTFLX,PREC &
760	& ,QCG,QS,QSG &
761	& ,QVG,QZ0 &
762	& ,RMOL &
763	& ,SFCEVP &
764	& ,SFCLHX,SFCSHX &
765	& ,SI,SMSTOT &
766	& ,SNO,SNOPCX &
767	& ,SOILT1 &
768	& ,SSROFF,SUBSHX &
769	& ,T2,THS,THZ0 &
770	& ,TSFC,TSNAV &
771	& ,USTAR,UZ0,UZ0H &
772	& ,VZ0,VZ0H &
773	& ,DEW & !RUC LSM
774	& ,Z0,Z0BASE
775	!
776	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: AKHS_OUT,AKMS_OUT &
777	& ,ALWIN,ALWOUT &
778	& ,ALWTOA,ASWIN &
779	& ,ASWOUT,ASWTOA &
780	& ,PSHLTR,Q10,QSHLTR &
781	& ,TH10,TSHLTR &
782	& ,U10,V10 & ! GWD
783	& ,UGWDsfc,VGWDsfc ! GWD
784	!
785	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: GRNFLX,QWBS,RADOT &
786	,SFCEXC,SMSTAV &
787	,SOILTB,TWBS
788	!
789
790	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: taux, tauy
791	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: PINT
792	!
793	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: CWM &
794	& ,DUDT &
795	& ,DVDT &
796	& ,Q,Q2 &
797	& ,T,U,V
798	!
799	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: F_ICE & !<--- Used only in physics (IKJ)
800	& ,F_RAIN &
801	& ,RQVBLTEN &
802	& ,RTHBLTEN
803	!
804	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(OUT) :: EL_MYJ & !<--- Used only in physics (IKJ)
805	& ,EXCH_H &
806	& ,EXCH_M
807	!
808	REAL,DIMENSION(IMS:IME,NSOIL,JMS:JME),INTENT(INOUT) :: KEEPFR3DFLAG & !<--- Used only in physics (IKJ)
809	& ,SH2O,SMC &
810	& ,SMFR3D,STC
811	!
812	REAL,DIMENSION(IMS:IME,NSOIL,JMS:JME) :: SMCREL
813	!
814	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME,N_MOIST) &
815	& ,INTENT(INOUT) :: MOIST
816	!
817	LOGICAL,INTENT(IN) :: RESTRT
818	!
819	TYPE(DOMAIN),TARGET :: GRID
820	!
821	TYPE(GRID_CONFIG_REC_TYPE),INTENT(IN) :: CONFIG_FLAGS
822	!
823	! For precip assimilation:
824	LOGICAL,INTENT(IN) :: PCPFLG
825	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DDATA
826	!
827	!-----------------------------------------------------------------------
828	!***
829	!*** LOCAL VARIABLES
830	!***
831	!-----------------------------------------------------------------------
832	INTEGER :: I,I_M,IDUMMY,IEND,ISFFLX,ISTAT,ISTR,J,K,KOUNT_ALL &
833	& ,LENGTH_ROW,LLIJ,LLYR,N,SST_UPDATE,SF_URBAN_PHYSICS,NUM_URBAN_LAYERS
834	!
835	INTEGER,DIMENSION(IMS:IME,JMS:JME) :: KPBL,LOWLYR
836	!
837	REAL :: TRESH=0.95
838	!
839	REAL :: ALTITUDE,CWML,DQDT,DTDT,DTPHS,DX,DZHALF,FACTR,FACTRL &
840	& ,G_INV,PLYR,PSFC,QI,QL,QOLD,QR,QW,RATIOMX,RDTPHS &
841	& ,ROG,RWMSK,SDEPTH,SNO_FACTR,TL,TLMH,TLMH4,TNEW,TSFC2 &
842	& ,U_FRAME,V_FRAME,XLVRW
843	!
844	REAL :: APES,CAPA,CKLQ,EXNER,FACTOR,FFS,PQ0X,Q2SAT,QFC1,QLOWX &
845	& ,RLIVWV,THBOT,DPL
846	!
847	REAL,DIMENSION(IMS:IME,JMS:JME) :: BR,CHKLOWQ,CT,CWMLOW,ELFLX &
848	& ,EXNSFC,FACTRS,FLHC,FLQC,GZ1OZ0 &
849	& ,ONE,PDSL,PLM,PSFC_OUT,PSIH &
850	& ,PSIM,Q2X,QLOW,RAIN,RAINBL &
851	& ,RLW_DN_SFC,RSW_NET_SFC &
852	& ,RSW_DN_SFC &
853	& ,SFCEVPX,SFCZ,SNOW,SNOWC,SNOWH &
854	& ,TH2X,THLOW,TLOW,VGFRCK &
855	& ,WSPD,XLAND,REGIME,HOL
856	!
857	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: DUDT_PHY,DVDT_PHY,DZ &
858	& ,P_PHY,P8W,PI_PHY &
859	& ,RQCBLTEN,RQIBLTEN &
860	!BSF & ,RQSBLTEN,RQRBLTEN,RQGBLTEN &
861	& ,RR,DELP & ! GWD
862	& ,T_PHY,TH_PHY,TKE &
863	& ,DUDT_GWD,DVDT_GWD & ! GWD
864	& ,U_PHY,V_PHY,Z
865	!
866	REAL,DIMENSION(:,:,:,:),ALLOCATABLE :: MOIST_TRANS
867	!
868	REAL,DIMENSION(IMS:IME,NSOIL,JMS:JME) :: ZERO_SOIL
869	!
870	LOGICAL :: E_BDY,WARM_RAIN
871	!
872	INTEGER :: NUM_ROOF_LAYERS,NUM_WALL_LAYERS,NUM_ROAD_LAYERS ! urban
873	INTEGER :: FRACTIONAL_SEAICE
874	!
875	INTEGER :: IGS,IGE,JGS,JGE, PQ_I !BSF
876	LOGICAL :: FQ_I !BSF
877
878	CHARACTER(len=255) :: message
879	!dbg integer :: kpblmin,kpblmax,lpblmin,lpblmax !dbg
880	!
881	!
882	INTEGER :: isurban
883	CHARACTER(len=256) :: MMINLU
884	!-----------------------------------------------------------------------
885	!***********************************************************************
886	!-----------------------------------------------------------------------
887	!
888	ALLOCATE(MOIST_TRANS(IMS:IME,KMS:KME,JMS:JME,N_MOIST),STAT=ISTAT)
889	!
890	SF_URBAN_PHYSICS=CONFIG_FLAGS%SF_URBAN_PHYSICS
891
892	if ( config_flags%bl_pbl_physics == BOULACSCHEME ) then
893	call wrf_error_fatal("Cannot use BOULAC PBL with NMM")
894	endif
895
896	FRACTIONAL_SEAICE = CONFIG_FLAGS%FRACTIONAL_SEAICE
897	IF ( FRACTIONAL_SEAICE == 1 ) THEN
898	CALL WRF_ERROR_FATAL("NMM cannot use FRACTIONAL_SEAICE = 1.")
899	ENDIF
900	!
901	DTPHS=NPHS*DT
902	RDTPHS=1./DTPHS
903	G_INV=1./G
904	ROG=R_D*G_INV
905	FACTOR=-XLV*RHOWATER/DTPHS
906	CAPA=R_D/CP
907	!
908	U_FRAME=0.
909	V_FRAME=0.
910	!
911	IDUMMY=0
912	ISFFLX=1
913	DX=0.
914	SST_UPDATE=config_flags%SST_UPDATE
915	!
916	!$omp parallel do &
917	!$omp& private(i,j)
918	DO J=JMS,JME
919	DO I=IMS,IME
920	UZ0H(I,J)=0.
921	VZ0H(I,J)=0.
922	ONE(I,J)=1.
923	RMOL(I,J)=0. !Reciprocal of Monin-Obukhov length
924	SFCEVPX(I,J)=0. !Dummy for accumulated latent energy, not flux
925	ENDDO
926	ENDDO
927	!
928	IF(MODEL_CONFIG_REC%SF_SURFACE_PHYSICS(GRID%ID)==99)THEN
929	SNO_FACTR=1.
930	ELSE
931	SNO_FACTR=0.001
932	ENDIF
933	!
934	!$omp parallel do &
935	!$omp& private(i,j)
936	DO J=MYJS,MYJE
937	DO I=MYIS,MYIE
938	LOWLYR(I,J)=1
939	VGFRCK(I,J)=100.*VEGFRC(I,J)
940	SNOW(I,J)=SNO(I,J)
941	SNOWH(I,J)=SI(I,J)*SNO_FACTR
942	XLAND(I,J)=SM(I,J)+1.
943	T2(I,J)=TSFC(I,J)
944	ENDDO
945	ENDDO
946	!
947	IF(NTSD==0)THEN
948	!$omp parallel do &
949	!$omp& private(i,j)
950	DO J=MYJS,MYJE
951	DO I=MYIS,MYIE
952	Z0BASE(I,J)=Z0(I,J)
953	IF(SM(I,J)>0.5.AND.SICE(I,J)>0.5)THEN !Bandaid
954	SM(I,J)=0.
955	ENDIF
956	ENDDO
957	ENDDO
958	ENDIF
959	!
960	!$omp parallel do &
961	!$omp& private(i,j,k)
962	DO J=MYJS,MYJE
963	DO K=KTS,KTE+1
964	DO I=MYIS,MYIE
965	Z(I,K,J)=0.
966	DZ(I,K,J)=0.
967	EXCH_H(I,K,J)=0.
968	EXCH_M(I,K,J)=0.
969	ENDDO
970	ENDDO
971	ENDDO
972	!
973	!-----------------------------------------------------------------------
974	!
975	!*** PREPARE NEEDED ARRAYS FOR CALLING THE INNER DRIVER.
976	!
977	!-----------------------------------------------------------------------
978	!
979	!$omp parallel do &
980	!$omp& private(factrl,i,j,llij,tlmh)
981	DO J=MYJS,MYJE
982	DO I=MYIS,MYIE
983	!
984	PDSL(I,J)=PD(I,J)*RES(I,J)
985	!!! PSFC=PD(I,J)+PDTOP+PT
986	!!! P8W(I,KTS,J)=PSFC
987	P8W(I,KTS,J)=PINT(I,J,KTS)
988	PSFC=PINT(I,J,KTS)
989	LOWLYR(I,J)=KTS !<---- The lowest model layer counted from the bottom.
990	EXNSFC(I,J)=(1.E5/PSFC)**CAPA
991	THS(I,J)=(SST(I,J)EXNSFC(I,J))SM(I,J)+THS(I,J)*(1.-SM(I,J))
992	TSFC(I,J)=THS(I,J)/EXNSFC(I,J)
993	SFCZ(I,J)=FIS(I,J)*G_INV
994	!YL RAIN(I,J)=PREC(I,J)*RHOWATER
995	IF (PCPFLG.AND.DDATA(I,J)<100.)THEN
996	RAIN(I,J)=DDATA(I,J)*RHOWATER
997	ELSE
998	RAIN(I,J)=PREC(I,J)*RHOWATER
999	ENDIF
1000	!YL
1001	RAINBL(I,J)=0.
1002	IF(SNO(I,J)>0.)SNOWC(I,J)=1.
1003	LLIJ=LOWLYR(I,J)
1004	PLM(I,J)=(PINT(I,J,LLIJ)+PINT(I,J,LLIJ+1))*0.5
1005	TH2X(I,J)=T(I,J,LLIJ)(1.E5/PLM(I,J))*CAPA
1006	Q2X(I,J)=Q(I,J,LLIJ)
1007	!
1008	!-----------------------------------------------------------------------
1009	!*** LONG AND SHORTWAVE FLUX AT GROUND SURFACE
1010	!-----------------------------------------------------------------------
1011	!
1012	IF(CZMEAN(I,J)>0.)THEN
1013	FACTRS(I,J)=CZEN(I,J)/CZMEAN(I,J)
1014	ELSE
1015	FACTRS(I,J)=0.
1016	ENDIF
1017	!
1018	IF(SIGT4(I,J)>0.)THEN
1019	TLMH=T(I,J,LLIJ)
1020	FACTRL=STBOLTTLMHTLMHTLMHTLMH/SIGT4(I,J)
1021	ELSE
1022	FACTRL=0.
1023	ENDIF
1024	!
1025	!- RLWIN/RSWIN - downward longwave/shortwave at the surface
1026	!
1027	RLW_DN_SFC(I,J)=RLWIN(I,J)HBM2(I,J)FACTRL
1028	RSW_NET_SFC(I,J)=(RSWIN(I,J)-RSWOUT(I,J))HBM2(I,J)FACTRS(I,J)
1029	!
1030	!- Instant downward solar for nmm_lsm
1031	!
1032	RSW_DN_SFC(I,J)=RSWIN(I,J)HBM2(I,J)FACTRS(I,J)
1033	!
1034	Z(I,KTS,J)=SFCZ(I,J)
1035	!
1036	ENDDO
1037	ENDDO
1038	!
1039	!-----------------------------------------------------------------------
1040	!*** FILL THE ARRAYS FOR CALLING THE INNER DRIVER.
1041	!-----------------------------------------------------------------------
1042	!
1043	!$omp parallel do &
1044	!$omp& private(cwml,i,j,k,plyr,qi,ql,qr,qw,tl)
1045	DO J=MYJS,MYJE
1046	DO K=KTS,KTE
1047	DO I=MYIS,MYIE
1048	Q2(I,J,K)=MAX(Q2(I,J,K)*HBM2(I,J),EPSQ2)
1049	QL=MAX(Q(I,J,K),EPSQ)
1050	PLYR=(PINT(I,J,K)+PINT(I,J,K+1))*0.5
1051	!!! PLYR=AETA1(K)PDTOP+AETA2(K)PDSL(I,J)+PT
1052	TL=T(I,J,K)
1053	CWML=CWM(I,J,K)
1054	!
1055	RR(I,K,J)=PLYR/(R_D*TL)
1056	T_PHY(I,K,J)=TL
1057	!
1058	EXNER=(1.E5/PLYR)**CAPA
1059	PI_PHY(I,K,J)=1./EXNER
1060	TH_PHY(I,K,J)=TL*EXNER
1061	P8W(I,K+1,J)=PINT(I,J,K+1)
1062	!!! P8W(I,K+1,J)=ETA1(K+1)PDTOP+ETA2(K+1)PDSL(I,J)+PT
1063	P_PHY(I,K,J)=PLYR
1064	TKE(I,K,J)=0.5*Q2(I,J,K)
1065	!
1066	RTHBLTEN(I,K,J)=0.
1067	RQVBLTEN(I,K,J)=0.
1068	RQCBLTEN(I,K,J)=0.
1069	RQIBLTEN(I,K,J)=0.
1070	!BSF RQSBLTEN(I,K,J)=0.
1071	!BSF RQRBLTEN(I,K,J)=0.
1072	!BSF RQGBLTEN(I,K,J)=0.
1073	!
1074	!-- Next 3 lines modified for GWD
1075	!
1076	DPL=DETA1(K)PDTOP+DETA2(K)PDSL(I,J)
1077	Z(I,K+1,J)=Z(I,K,J)+TL/PLYRDPLROG(Q(I,J,K)P608-CWML+1.)
1078	DELP(I,K,J)=DPL
1079	DZ(I,K,J)=Z(I,K+1,J)-Z(I,K,J)
1080	ENDDO
1081	ENDDO
1082	ENDDO
1083	!
1084	!$omp parallel do &
1085	!$omp& private(i,j,llyr,qlowx)
1086	DO J=MYJS,MYJE
1087	DO I=MYIS,MYIE
1088	TWBS(I,J)=0.
1089	QWBS(I,J)=0.
1090	LLYR=LOWLYR(I,J)
1091	THLOW(I,J)=TH_PHY(I,LLYR,J)
1092	TLOW(I,J)=T_PHY(I,LLYR,J)
1093	QLOW(I,J)=MAX(Q(I,J,LLYR),EPSQ)
1094	QLOWX=QLOW(I,J)/(1.-QLOW(I,J))
1095	QLOW(I,J)=QLOWX/(1.+QLOWX)
1096	CWMLOW(I,J)=CWM(I,J,LLYR)
1097	PBLH(I,J)=MAX(PBLH(I,J),0.)
1098	PBLH(I,J)=MIN(PBLH(I,J),Z(I,KTE,J))
1099	ENDDO
1100	ENDDO
1101	!-----------------------------------------------------------------------
1102	!
1103	!*** COMPUTE VELOCITY COMPONENTS AT MASS POINTS
1104	!
1105	!-----------------------------------------------------------------------
1106	!$omp parallel do &
1107	!$omp& private(i,j,k)
1108	DO K=KTS,KTE
1109	DO J=MYJS1_P1,MYJE1_P1
1110	DO I=MYIS_P1,MYIE_P1
1111	U_PHY(I,K,J)=(U(I+IHE(J),J,K)+U(I+IHW(J),J,K) &
1112	& +U(I,J+1,K)+U(I,J-1,K)) &
1113	& *0.25
1114	V_PHY(I,K,J)=(V(I+IHE(J),J,K)+V(I+IHW(J),J,K) &
1115	& +V(I,J+1,K)+V(I,J-1,K)) &
1116	& *0.25
1117	ENDDO
1118	ENDDO
1119	ENDDO
1120	!
1121	!$omp parallel do &
1122	!$omp& private(i,iend,istr,j)
1123	DO J=MYJS1_P1,MYJE1_P1
1124	IF(MOD(J,2)==0)THEN
1125	ISTR=MYIS_P1
1126	IEND=MIN(MYIE_P1,IDE-1)
1127	ELSE
1128	ISTR=MAX(MYIS_P1,IDS+1)
1129	IEND=MIN(MYIE_P1,IDE-1)
1130	ENDIF
1131	!
1132	DO I=ISTR,IEND
1133	UZ0H(I,J)=(UZ0(I+IHE(J),J)+UZ0(I+IHW(J),J) &
1134	& +UZ0(I,J+1)+UZ0(I,J-1))*0.25
1135	!!! & +UZ0(I,J+1)+UZ0(I,J-1))HBM2(I,J)0.25
1136	VZ0H(I,J)=(VZ0(I+IHE(J),J)+VZ0(I+IHW(J),J) &
1137	& +VZ0(I,J+1)+VZ0(I,J-1))*0.25
1138	!!! & +VZ0(I,J+1)+VZ0(I,J-1))HBM2(I,J)0.25
1139	ENDDO
1140	ENDDO
1141	!
1142	!-----------------------------------------------------------------------
1143	!*** SET MAVAIL EQUAL TO 1. ONLY FOR NMM LSM
1144	!-----------------------------------------------------------------------
1145	!
1146	DO J=JTS,JTE
1147	DO I=ITS,ITE
1148	IF(MODEL_CONFIG_REC%SF_SURFACE_PHYSICS(GRID%ID)==2.OR. &
1149	MODEL_CONFIG_REC%SF_SURFACE_PHYSICS(GRID%ID)==99)THEN
1150	ONE(I,J)=1.
1151	ELSE
1152	!*** MAVAIL should not be equal to 1. for other LSMs
1153	ONE(I,J)=MAVAIL(I,J)
1154	ENDIF
1155	ENDDO
1156	ENDDO
1157	!
1158	!-----------------------------------------------------------------------
1159	!*** TRANSPOSE THE MOIST ARRAY (IJK) FOR THE PHYSICS (IKJ).
1160	!-----------------------------------------------------------------------
1161	!
1162	DO N=1,N_MOIST
1163	!$omp parallel do &
1164	!$omp& private(i,j,k)
1165	DO K=KMS,KME
1166	DO J=JMS,JME
1167	DO I=IMS,IME
1168	MOIST_TRANS(I,K,J,N)=MOIST(I,J,K,N)
1169	ENDDO
1170	ENDDO
1171	ENDDO
1172	ENDDO
1173	!
1174	!-----------------------------------------------------------------------
1175	!*** URBAN RELATED VARIABLES ARE ADDED TO ARGUMENTS OF SURFACE_DRIVER
1176	!-----------------------------------------------------------------------
1177	!
1178	NUM_ROOF_LAYERS=GRID%NUM_SOIL_LAYERS !urban
1179	NUM_WALL_LAYERS=GRID%NUM_SOIL_LAYERS !urban
1180	NUM_ROAD_LAYERS=GRID%NUM_SOIL_LAYERS !urban
1181	CALL nl_get_isurban(grid%id, isurban)
1182	call nl_get_mminlu(grid%id, mminlu)
1183	!
1184	!-----------------------------------------------------------------------
1185	!
1186	!*** CALL SURFACE LAYER AND LAND SURFACE PHYSICS
1187	!
1188	!-----------------------------------------------------------------------
1189	!
1190	CALL SET_TILES(GRID,IDS,IDE-1,JDS+1,JDE-1,ITS,ITE,JTS,JTE)
1191	!
1192	CALL SURFACE_DRIVER( &
1193	& ACSNOM=ACSNOM,ACSNOW=ACSNOW,AKHS=AKHS,AKMS=AKMS &
1194	& ,ALBEDO=ALBEDO,BR=BR,CANWAT=CMC,CHKLOWQ=CHKLOWQ &
1195	& ,DT=DT,DX=DX,DZ8W=DZ,DZS=DZSOIL,GLW=RLW_DN_SFC &
1196	& ,GRDFLX=GRNFLX,GSW=RSW_NET_SFC,SWDOWN=RSW_DN_SFC &
1197	& ,GZ1OZ0=GZ1OZ0,HFX=TWBS &
1198	& ,HT=SFCZ,IFSNOW=IDUMMY,ISFFLX=ISFFLX &
1199	& ,FRACTIONAL_SEAICE=FRACTIONAL_SEAICE &
1200	& ,TICE2TSK_IF2COLD=CONFIG_FLAGS%TICE2TSK_IF2COLD &
1201	& ,ISLTYP=ISLTYP &
1202	& ,ITIMESTEP=NTSD,IVGTYP=IVGTYP,LOWLYR=LOWLYR &
1203	& ,MAVAIL=ONE,RMOL=RMOL,MOL=MOL &
1204	& ,NUM_SOIL_LAYERS=NSOIL,P8W=P8W &
1205	& ,PBLH=PBLH,PI_PHY=PI_PHY,PSHLTR=PSHLTR,PSIH=PSIH &
1206	& ,PSIM=PSIM,P_PHY=P_PHY,Q10=Q10,Q2=Q2X,QFX=QWBS,TAUX=TAUX,TAUY=TAUY,QSFC=QS &
1207	& ,QSHLTR=QSHLTR,QZ0=QZ0,RAINCV=RAIN &
1208	& ,RHO=RR,SFCEVP=SFCEVPX,SFCEXC=SFCEXC,SFCRUNOFF=SSROFF &
1209	& ,SMOIS=SMC,SMSTAV=SMSTAV,SMSTOT=SMSTOT,SNOALB=MXSNAL &
1210	& ,SNOW=SNOW,SNOWC=SNOWC,SNOWH=SNOWH,STEPBL=NPHS &
1211	& ,SMCREL=SMCREL &
1212	& ,SST=SST,SST_UPDATE=SST_UPDATE &
1213	& ,TH10=TH10,TH2=TH2X,T2=T2,THZ0=THZ0,TH_PHY=TH_PHY &
1214	& ,TMN=TG,TSHLTR=TSHLTR,TSK=TSFC,TSLB=STC,T_PHY=T_PHY &
1215	& ,U10=U10,UDRUNOFF=BGROFF,UST=USTAR,UZ0=UZ0H &
1216	& ,U_FRAME=U_FRAME,U_PHY=U_PHY,V10=V10,VEGFRA=VGFRCK &
1217	& ,VZ0=VZ0H,V_FRAME=V_FRAME,V_PHY=V_PHY &
1218	& ,WARM_RAIN=WARM_RAIN,WSPD=WSPD,XICE=SICE,XICEM=SICE &
1219	& ,ISICE=GRID%LANDUSE_ISICE,ISWATER=GRID%ISWATER &
1220	& ,XLAND=XLAND,Z=Z,ZNT=Z0,ZS=SLDPTH,CT=CT,TKE_PBL=TKE,SFENTH=SFENTH &
1221	& ,ALBBCK=ALBASE,LH=ELFLX,SH2O=SH2O,SHDMAX=SHDMAX &
1222	& ,SHDMIN=SHDMIN,Z0=Z0BASE,FLQC=FLQC,FLHC=FLHC &
1223	& ,PSFC=PSFC_OUT,EMISS=EPSR,EMBCK=EMBCK &
1224	& ,SF_SFCLAY_PHYSICS=CONFIG_FLAGS%SF_SFCLAY_PHYSICS &
1225	& ,SF_SURFACE_PHYSICS=CONFIG_FLAGS%SF_SURFACE_PHYSICS &
1226	& ,RA_LW_PHYSICS=CONFIG_FLAGS%RA_LW_PHYSICS &
1227	& ,LAI=GRID%LAI,IZ0TLND=CONFIG_FLAGS%IZ0TLND &
1228	& ,SF_URBAN_PHYSICS=SF_URBAN_PHYSICS &
1229	! & ,GMT=GMT,XLAT=XLAT,XLONG=XLONG,JULDAY=JULDAY &
1230	& ,NUM_URBAN_LAYERS=NUM_URBAN_LAYERS &
1231	& ,IDS=IDS,IDE=IDE,JDS=JDS,JDE=JDE,KDS=KDS,KDE=KDE &
1232	& ,IMS=IMS,IME=IME,JMS=JMS,JME=JME,KMS=KMS,KME=KME &
1233	& ,I_START=GRID%I_START,I_END=GRID%I_END &
1234	& ,J_START=GRID%J_START,J_END=GRID%J_END &
1235	& ,KTS=KTS,KTE=KTE,NUM_TILES=GRID%NUM_TILES &
1236	! Optional args
1237	& ,QV_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QV),F_QV=F_QV &
1238	& ,QC_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QC),F_QC=F_QC &
1239	& ,QR_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QR),F_QR=F_QR &
1240	& ,QI_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QI),F_QI=F_QI &
1241	& ,QS_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QS),F_QS=F_QS &
1242	& ,QG_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QG),F_QG=F_QG &
1243	& ,RAINBL=RAINBL &
1244	& ,LAGDAY=1 & ! tmn_update
1245	! for RUCLSM
1246	& ,QSG=QSG,QVG=QVG,QCG=QCG,SOILT1=SOILT1 &
1247	& ,TSNAV=TSNAV,SMFR3D=SMFR3D,KEEPFR3DFLAG=KEEPFR3DFLAG &
1248	& ,POTEVP=POTEVP,SNOPCX=SNOPCX,SOILTB=SOILTB,SR=SR &
1249	& ,DEW=DEW &
1250	! for URBAN
1251	& ,NUM_ROOF_LAYERS=NUM_ROOF_LAYERS & ! urban
1252	& ,NUM_WALL_LAYERS=NUM_WALL_LAYERS & ! urban
1253	& ,NUM_ROAD_LAYERS=NUM_ROAD_LAYERS & ! urban
1254	! for YSU
1255	& ,REGIME=REGIME &
1256	! for PX LSM
1257	& ,NLCAT=grid%num_land_cat, NSCAT=grid%num_soil_cat & ! P-X LSM
1258	& ,ISURBAN=isurban, MMINLU=TRIM(mminlu) &
1259	& ,SNOTIME = grid%SNOTIME &
1260	& ,RDLAI2D=config_flags%rdlai2d &
1261	& ,usemonalb=config_flags%usemonalb &
1262	& ,NOAHRES=grid%noahres &
1263	& )
1264	!
1265	!-----------------------------------------------------------------------
1266	!
1267	!*** CALL FREE ATMOSPHERE TURBULENCE
1268	!
1269	!-----------------------------------------------------------------------
1270	!
1271	!$omp parallel do &
1272	!$omp& private(i,j,k)
1273	DO J=JMS,JME
1274	DO K=KMS,KME
1275	DO I=IMS,IME
1276	DUDT_PHY(I,K,J)=0.
1277	DVDT_PHY(I,K,J)=0.
1278	ENDDO
1279	ENDDO
1280	ENDDO
1281	!
1282	!*** THE SURFACE EXCHANGE COEFFICIENTS AKHS AND AKMS ARE ACTUALLY
1283	!*** MULTIPLIED BY HALF THE DEPTH OF THE LOWEST LAYER. WE MUST RETAIN
1284	!*** THOSE VALUES FOR THE NEXT TIMESTEP SO USE AUXILLIARY ARRAYS FOR
1285	!*** THE OUTPUT.
1286	!
1287	!$omp parallel do &
1288	!$omp& private(dzhalf,i,j)
1289	DO J=JTS,JTE
1290	DO I=ITS,ITE
1291	DZHALF=0.5*DZ(I,KTS,J)
1292	AKHS_OUT(I,J)=AKHS(I,J)*DZHALF
1293	AKMS_OUT(I,J)=AKMS(I,J)*DZHALF
1294	ENDDO
1295	ENDDO
1296	!
1297	!BSF: Logical FQ_I index PQ_I are set to values associated with snow
1298	! for the ETAMPNEW scheme so that they can be mixed by the PBL schemes.
1299	!
1300	IF(CONFIG_FLAGS%MP_PHYSICS==ETAMPNEW)THEN
1301	FQ_I=F_QS
1302	PQ_I=P_QS
1303	ELSE
1304	FQ_I=F_QI
1305	PQ_I=P_QI
1306	ENDIF
1307	!
1308	CALL PBL_DRIVER( &
1309	& ITIMESTEP=NTSD,DT=DT &
1310	& ,U_FRAME=U_FRAME,V_FRAME=V_FRAME &
1311	& ,RUBLTEN=DUDT_PHY,RVBLTEN=DVDT_PHY &
1312	& ,RTHBLTEN=RTHBLTEN,RQVBLTEN=RQVBLTEN & !BSF
1313	& ,RQCBLTEN=RQCBLTEN,RQIBLTEN=RQIBLTEN & !BSF
1314	!BSF & ,RQRBLTEN=RQRBLTEN,RQSBLTEN=RQSBLTEN & !BSF
1315	!BSF & ,RQGBLTEN=RQGBLTEN & !BSF
1316	& ,TSK=TSFC,XLAND=XLAND,ZNT=Z0,HT=SFCZ &
1317	& ,UST=USTAR,MIXHT=MIXHT,PBLH=PBLH &
1318	& ,HFX=TWBS,QFX=QWBS,GRDFLX=GRNFLX &
1319	& ,U_PHY=U_PHY,V_PHY=V_PHY,TH_PHY=TH_PHY,RHO=RR &
1320	& ,P_PHY=P_PHY,PI_PHY=PI_PHY,P8W=P8W,T_PHY=T_PHY &
1321	& ,DZ8W=DZ,Z=Z,TKE_PBL=TKE,EL_PBL=EL_MYJ,F=F &
1322	& ,EXCH_H=EXCH_H,EXCH_M=EXCH_M,AKHS=AKHS,AKMS=AKMS &
1323	& ,THZ0=THZ0,QZ0=QZ0,UZ0=UZ0H,VZ0=VZ0H &
1324	& ,QSFC=QS,LOWLYR=LOWLYR &
1325	& ,PSIM=PSIM,PSIH=PSIH,GZ1OZ0=GZ1OZ0 &
1326	& ,U10=U10,V10=V10,T2=T2,WSPD=WSPD,BR=BR,CHKLOWQ=CHKLOWQ &
1327	& ,DX=DX,STEPBL=NPHS,WARM_RAIN=WARM_RAIN &
1328	& ,KPBL=KPBL,CT=CT,LH=ELFLX,SNOW=SNOW,XICE=SICE &
1329	& ,BL_PBL_PHYSICS=config_flags%bl_pbl_physics &
1330	& ,RA_LW_PHYSICS=config_flags%ra_lw_physics &
1331	& ,IDS=IDS,IDE=IDE,JDS=JDS,JDE=JDE,KDS=KDS,KDE=KDE &
1332	& ,IMS=IMS,IME=IME,JMS=JMS,JME=JME,KMS=KMS,KME=KME &
1333	& ,I_START=GRID%I_START,I_END=GRID%I_END &
1334	& ,J_START=GRID%J_START,J_END=GRID%J_END &
1335	& ,KTS=KTS,KTE=KTE,NUM_TILES=GRID%NUM_TILES &
1336	#if (NMM_CORE==1)
1337	& ,DISHEAT=DISHEAT &
1338	#endif
1339	! Optional args
1340	& ,QV_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QV),F_QV=F_QV &
1341	& ,QC_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QC),F_QC=F_QC &
1342	& ,QI_CURR=MOIST_TRANS(IMS,KMS,JMS,PQ_I),F_QI=FQ_I &
1343	& ,QR_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QR),F_QR=F_QR &
1344	& ,QS_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QS),F_QS=F_QS &
1345	& ,QG_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QG),F_QG=F_QG &
1346	& ,HOL=HOL,sf_sfclay_physics=CONFIG_FLAGS%SF_SFCLAY_PHYSICS &
1347	& ,sf_urban_physics=CONFIG_FLAGS%SF_URBAN_PHYSICS)
1348	!
1349	!*** NOTE THAT THE EXCHANGE COEFFICIENTS FOR HEAT EXCH_H COMING OUT OF
1350	!*** PBL_DRIVER ARE DEFINED AT THE TOPS OF THE LAYERS KTS TO KTE-1
1351	!*** IF MODULE_BL_MYJPBL WAS INVOKED.
1352	!
1353	!-----------------------------------------------------------------------
1354	! UNCOMPUTED LOCATIONS MUST BE FILLED IN FOR THE POST-PROCESSOR
1355	!-----------------------------------------------------------------------
1356	!
1357	!*** EASTERN GLOBAL BOUNDARY
1358	!
1359	IF(MYIE==IDE)THEN
1360	!$omp parallel do &
1361	!$omp& private(i,j)
1362	DO J=JDS,JDE
1363	IF (J>=MYJS.AND.J<=MYJE)THEN
1364	TH10(MYIE,J)=TH10(MYIE-1,J)
1365	Q10(MYIE,J)=Q10(MYIE-1,J)
1366	U10(MYIE,J)=U10(MYIE-1,J)
1367	V10(MYIE,J)=V10(MYIE-1,J)
1368	TSHLTR(MYIE,J)=TSHLTR(MYIE-1,J)
1369	QSHLTR(MYIE,J)=QSHLTR(MYIE-1,J)
1370	ENDIF
1371	ENDDO
1372	ENDIF
1373	!
1374	!*** SOUTHERN GLOBAL BOUNDARY
1375	!
1376
1377	IF(MYJS==JDS)THEN
1378	DO J=JDS,JDS+1
1379	DO I=IDS,IDE
1380	IF (I>=MYIS.AND.I<=MYIE) THEN
1381	TH10(I,J)=TH10(I,MYJS+2)
1382	Q10(I,J)=Q10(I,MYJS+2)
1383	U10(I,J)=U10(I,MYJS+2)
1384	V10(I,J)=V10(I,MYJS+2)
1385	TSHLTR(I,J)=TSHLTR(I,MYJS+2)
1386	QSHLTR(I,J)=QSHLTR(I,MYJS+2)
1387	ENDIF
1388	ENDDO
1389	ENDDO
1390	ENDIF
1391	!
1392	!*** NORTHERN GLOBAL BOUNDARY
1393	!
1394	IF(MYJE==JDE)THEN
1395	!$omp parallel do &
1396	!$omp& private(i,j)
1397	DO J=MYJE-1,MYJE
1398	DO I=IDS,IDE
1399	IF (I>=MYIS.AND.I<=MYIE) THEN
1400	TH10(I,J)=TH10(I,MYJE-2)
1401	Q10(I,J)=Q10(I,MYJE-2)
1402	U10(I,J)=U10(I,MYJE-2)
1403	V10(I,J)=V10(I,MYJE-2)
1404	TSHLTR(I,J)=TSHLTR(I,MYJE-2)
1405	QSHLTR(I,J)=QSHLTR(I,MYJE-2)
1406	ENDIF
1407	ENDDO
1408	ENDDO
1409	ENDIF
1410	!
1411	IF(CONFIG_FLAGS%SF_SFCLAY_PHYSICS==1)THEN ! non-NMM package
1412	!$omp parallel do &
1413	!$omp& private(i,j)
1414	DO J=MYJS1,MYJE1
1415	DO I=MYIS,MYIE1
1416	! TSHLTR(I,J)=TSHLTR(I,J)(1.E5/PSHLTR(I,J))*RCP
1417	IF(TSHLTR(I,J)<200..OR.TSHLTR(I,J)>350.)THEN
1418	WRITE(message,*)'Troublesome TSHLTR...I,J,TSHLTR,PSHLTR: ' &
1419	,I,J,TSHLTR(I,J),PSHLTR(I,J)
1420	CALL wrf_message(trim(message))
1421	ENDIF
1422	ENDDO
1423	ENDDO
1424	ENDIF
1425	!
1426	!-----------------------------------------------------------------------
1427	!*** COMPUTE MODEL LAYER CONTAINING THE TOP OF THE BOUNDARY LAYER
1428	!-----------------------------------------------------------------------
1429	!
1430	IF(CONFIG_FLAGS%BL_PBL_PHYSICS/=MYJPBLSCHEME)THEN
1431	LENGTH_ROW=MYIE1-MYIS1+1
1432	DO J=MYJS2,MYJE2
1433	DO I=MYIS1,MYIE1
1434	KPBL(I,J)=-1000
1435	ENDDO
1436	ENDDO
1437	!
1438	!$omp parallel do &
1439	!$omp& private(altitude,i,j,k,kount_all)
1440	DO J=MYJS2,MYJE2
1441	KOUNT_ALL=0
1442	find_kpbl : DO K=KTS,KTE
1443	DO I=MYIS1,MYIE1
1444	ALTITUDE=Z(I,K+1,J)-SFCZ(I,J)
1445	IF(PBLH(I,J)<=ALTITUDE.AND.KPBL(I,J)<0)THEN
1446	KPBL(I,J)=K
1447	KOUNT_ALL=KOUNT_ALL+1
1448	ENDIF
1449	IF(KOUNT_ALL==LENGTH_ROW)EXIT find_kpbl
1450	ENDDO
1451	ENDDO find_kpbl
1452	ENDDO
1453	ENDIF
1454	!
1455	IF(MODEL_CONFIG_REC%SF_SURFACE_PHYSICS(GRID%ID)==99)THEN
1456	SNO_FACTR=1.
1457	ELSE
1458	SNO_FACTR=1000.
1459	ENDIF
1460	!
1461	!$omp parallel do &
1462	!$omp& private(i,j)
1463	DO J=MYJS2,MYJE2
1464	DO I=MYIS1,MYIE1
1465	SNO(I,J)=SNOW(I,J)
1466	SI(I,J)=SNOWH(I,J)*SNO_FACTR
1467	LPBL(I,J)=KTE-KPBL(I,J)+1
1468	ENDDO
1469	ENDDO
1470	!
1471	!-----------------------------------------------------------------------
1472	!*** DIAGNOSTIC RADIATION ACCUMULATION
1473	!-----------------------------------------------------------------------
1474	!
1475	!$omp parallel do &
1476	!$omp& private(i,j,tsfc2)
1477	DO J=MYJS2,MYJE2
1478	DO I=MYIS,MYIE
1479	ASWIN (I,J)=ASWIN (I,J)+RSWIN(I,J)HBM2(I,J)FACTRS(I,J)
1480	ASWOUT(I,J)=ASWOUT(I,J)-RSWOUT(I,J)HBM2(I,J)FACTRS(I,J)
1481	ASWTOA(I,J)=ASWTOA(I,J)+RSWTOA(I,J)HBM2(I,J)FACTRS(I,J)
1482	ALWIN (I,J)=ALWIN (I,J)+RLW_DN_SFC(I,J)
1483	ALWOUT(I,J)=ALWOUT(I,J)-RADOT (I,J)*HBM2(I,J)
1484	ALWTOA(I,J)=ALWTOA(I,J)+RLWTOA(I,J)*HBM2(I,J)
1485	!
1486	TSFC2=TSFC(I,J)*TSFC(I,J)
1487	RADOT(I,J)=HBM2(I,J)EPSR(I,J)STBOLTTSFC2TSFC2
1488	THS(I,J)=TSFC(I,J)*EXNSFC(I,J)
1489	PREC(I,J)=0.
1490	ENDDO
1491	ENDDO
1492	!
1493	!=======================================================================
1494	!=== Begin gravity wave drag (GWD) and mountain blocking (MB) ========
1495	!=======================================================================
1496	!
1497	IGS=MYIS1
1498	IGE=MYIE1
1499	JGS=MYJS2
1500	JGE=MYJE2
1501	!dbg !dbg
1502	!dbg kpblmin=100
1503	!dbg kpblmax=-100
1504	!dbg DO J=JGS,JGE
1505	!dbg DO I=IGS,IGE
1506	!dbg kpblmin=min(kpblmin,kpbl(i,j))
1507	!dbg kpblmax=max(kpblmax,kpbl(i,j))
1508	!dbg enddo
1509	!dbg enddo
1510	!dbg print *,'TURBL: IGS,IGE,JGS,JGE,kpblmin,kpblmax=',IGS,IGE,JGS,JGE,kpblmin,kpblmax
1511	!dbg
1512
1513	! print *,'grid%id gwd_opt at module_PHYSICS ',grid%id, grid%gwd_opt
1514	! WRITE(0,*)'grid%id gwd_opt at module_PHYSICS ',grid%id, grid%gwd_opt
1515	! WRITE(MESSAGE,125)grid%gwd_opt
1516	!125 FORMAT(1X,'grid%id module_PHYSICS.F : gwd_opt ',I2,2X,I2)
1517
1518
1519	#ifdef HWRF
1520	IF (grid%gwd_opt .eq. 2 .AND. grid%id.eq.1) THEN !Kwon's doing for parent only now
1521	#else
1522	IF (grid%gwd_opt .eq. 2) THEN
1523	#endif
1524	! print *,'==grid%id gwd_opt at module_PHYSICS inside gwd ',grid%id, grid%gwd_opt !because there is no data for nest domain
1525
1526	CALL wrf_message("GWD usage currently may be problematic for some cases - use at own risk")
1527
1528	CALL GWD_driver(U=U_PHY,V=V_PHY,T=T_PHY &
1529	& ,Q=MOIST_TRANS(IMS,KMS,JMS,P_QV) &
1530	& ,Z=Z,DP=DELP,PINT=P8W,PMID=P_PHY,EXNR=PI_PHY &
1531	& ,KPBL=KPBL,ITIME=NTSD &
1532	& ,HSTDV=HSTDV,HCNVX=HCNVX,HASYW=HASYW,HASYS=HASYS &
1533	& ,HASYSW=HASYSW,HASYNW=HASYNW,HLENW=HLENW &
1534	& ,HLENS=HLENS,HLENSW=HLENSW,HLENNW=HLENNW &
1535	& ,HANGL=HANGL,HANIS=HANIS,HSLOP=HSLOP,HZMAX=HZMAX &
1536	& ,CROT=CROT,SROT=SROT &
1537	& ,DUDT=DUDT_GWD,DVDT=DVDT_GWD &
1538	& ,UGWDsfc=UGWDsfc,VGWDsfc=VGWDsfc &
1539	& ,IDS=IDS,IDE=IDE,JDS=JDS,JDE=JDE,KDS=KDS,KDE=KDE &
1540	& ,IMS=IMS,IME=IME,JMS=JMS,JME=JME,KMS=KMS,KME=KME &
1541	& ,ITS=IGS,ITE=IGE,JTS=JGS,JTE=JGE,KTS=KTS,KTE=KTE )
1542
1543	!=======================================================================
1544	!===== End gravity wave drag (GWD) and mountain blocking (MB) ========
1545	!=======================================================================
1546	!
1547	!-----------------------------------------------------------------------
1548	!*** TRANSFER THE WIND TENDENCIES.
1549	!-----------------------------------------------------------------------
1550	!
1551	DO K=KTS,KTE
1552	DO J=JTS,JTE
1553	DO I=ITS,ITE
1554
1555
1556	!mp temporary bandaid limiting GWD/MB wind tendencies
1557
1558	IF (DUDT_GWD(I,K,J) .gt. 1.6) then
1559	write(message,*) 'BIG DUDT_GWD:: ', I,K,J, DUDT_GWD(I,K,J)
1560	CALL wrf_message(message)
1561	DUDT_GWD(I,K,J)=1.6
1562	ENDIF
1563
1564	IF (DUDT_GWD(I,K,J) .lt. -1.6) then
1565	write(message,*) 'BIG DUDT_GWD:: ', I,K,J, DUDT_GWD(I,K,J)
1566	CALL wrf_message(message)
1567	DUDT_GWD(I,K,J)=-1.6
1568	ENDIF
1569
1570	IF (DVDT_GWD(I,K,J) .gt. 1.6) then
1571	write(message,*) 'BIG DVDT_GWD:: ', I,K,J, DVDT_GWD(I,K,J)
1572	CALL wrf_message(message)
1573	DVDT_GWD(I,K,J)=1.6
1574	ENDIF
1575
1576	IF (DVDT_GWD(I,K,J) .lt. -1.6) then
1577	write(message,*) 'BIG DVDT_GWD:: ', I,K,J, DVDT_GWD(I,K,J)
1578	CALL wrf_message(message)
1579	DVDT_GWD(I,K,J)=-1.6
1580	ENDIF
1581
1582	!mp end temporary bandaid
1583
1584	DUDT(I,J,K)=DUDT_PHY(I,K,J)+DUDT_GWD(I,K,J)
1585	DVDT(I,J,K)=DVDT_PHY(I,K,J)+DVDT_GWD(I,K,J)
1586
1587	ENDDO
1588	ENDDO
1589	ENDDO
1590
1591	ELSE ! no GWD
1592
1593	DO K=KTS,KTE
1594	DO J=JTS,JTE
1595	DO I=ITS,ITE
1596	DUDT(I,J,K)=DUDT_PHY(I,K,J)
1597	DVDT(I,J,K)=DVDT_PHY(I,K,J)
1598	ENDDO
1599	ENDDO
1600	ENDDO
1601
1602	ENDIF ! gwd_opt
1603	!
1604	!-----------------------------------------------------------------------
1605	!*** TRANSPOSE THE MOIST_TRANS ARRAY BACK TO THE PROGNOSTIC MOIST ARRAY.
1606	!-----------------------------------------------------------------------
1607	!
1608	DO N=1,N_MOIST
1609	!$omp parallel do &
1610	!$omp& private(i,j,k)
1611	DO J=JMS,JME
1612	DO K=KMS,KME
1613	DO I=IMS,IME
1614	MOIST(I,J,K,N)=MOIST_TRANS(I,K,J,N)
1615	ENDDO
1616	ENDDO
1617	ENDDO
1618	ENDDO
1619	!
1620	DEALLOCATE(MOIST_TRANS,STAT=ISTAT)
1621	!
1622	!-----------------------------------------------------------------------
1623	!*** UPDATE TEMPERATURE, SPECIFIC HUMIDITY, CLOUD, AND TKE.
1624	!-----------------------------------------------------------------------
1625	!
1626	E_BDY=(ITE>=IDE)
1627	!
1628	!$omp parallel do &
1629	!$omp& private(dqdt,dtdt,i,iend,j,k,qi,qold,qr,qw,ratiomx,i_m)
1630	DO K=KTS,KTE
1631	DO J=MYJS2,MYJE2
1632	IEND=MYIE1
1633	IF(E_BDY.AND.MOD(J,2)==0)IEND=IEND-1
1634	!
1635	DO I=MYIS1,IEND
1636	DTDT=RTHBLTEN(I,K,J)*PI_PHY(I,K,J)
1637	DQDT=RQVBLTEN(I,K,J) !Mixing ratio tendency
1638	T(I,J,K)=T(I,J,K)+DTDT*DTPHS
1639	QOLD=Q(I,J,K)
1640	RATIOMX=QOLD/(1.-QOLD)+DQDT*DTPHS
1641	Q(I,J,K)=RATIOMX/(1.+RATIOMX)
1642	! Q(I,J,K)=MAX(Q(I,J,K),EPSQ)
1643	MOIST(I,J,K,P_QV)=MAX(EPSQ,(MOIST(I,J,K,P_QV)+RQVBLTEN(I,K,J)*DTPHS) )
1644	CWM(I,J,K)=0.
1645	!
1646	IF(CONFIG_FLAGS%MP_PHYSICS/=ETAMPNEW.and.CONFIG_FLAGS%MP_PHYSICS/=etamp_hwrf)THEN
1647	DO I_M=1,N_MOIST
1648	IF(I_M==P_QC) THEN
1649	MOIST(I,J,K,I_M)=MAX(EPSQ,(MOIST(I,J,K,I_M)+RQCBLTEN(I,K,J)*DTPHS) )
1650	ELSE IF(I_M==P_QI) THEN
1651	MOIST(I,J,K,I_M)=MAX(EPSQ,(MOIST(I,J,K,I_M)+RQIBLTEN(I,K,J)*DTPHS) )
1652	!BSF ELSE IF(I_M==P_QS) THEN
1653	!BSF MOIST(I,J,K,I_M)=MAX(EPSQ,(MOIST(I,J,K,I_M)+RQSBLTEN(I,K,J)*DTPHS) )
1654	!BSF ELSE IF(I_M==P_QR) THEN
1655	!BSF MOIST(I,J,K,I_M)=MAX(EPSQ,(MOIST(I,J,K,I_M)+RQRBLTEN(I,K,J)*DTPHS) )
1656	!BSF ELSE IF(I_M==P_QG) THEN
1657	!BSF MOIST(I,J,K,I_M)=MAX(EPSQ,(MOIST(I,J,K,I_M)+RQGBLTEN(I,K,J)*DTPHS) )
1658	ENDIF
1659	IF(I_M/=P_QV) CWM(I,J,K)=CWM(I,J,K)+MOIST(I,J,K,I_M)
1660	ENDDO
1661	ELSE
1662	!
1663	!-- Allow vertical mixing to modify cloud ice + snow for ETAMPNEW
1664	!
1665	QW=MAX(0.,MOIST(I,J,K,P_QC)+RQCBLTEN(I,K,J)*DTPHS )
1666	if(CONFIG_FLAGS%MP_PHYSICS.eq.etampnew)then
1667	QI=MAX(0.,MOIST(I,J,K,P_QS)+RQIBLTEN(I,K,J)*DTPHS ) !-- Total ice
1668	!BSF QR=MAX(0.,MOIST(I,J,K,P_QR)+RQRBLTEN(I,K,J)*DTPHS )
1669	QR=MAX(0.,MOIST(I,J,K,P_QR) )
1670	MOIST(I,J,K,P_QC)=QW
1671	MOIST(I,J,K,P_QS)=QI
1672	MOIST(I,J,K,P_QR)=QR
1673	elseif(CONFIG_FLAGS%MP_PHYSICS.eq.etamp_hwrf)then
1674	QI=MAX(0.,MOIST(I,J,K,P_QI)+RQIBLTEN(I,K,J)*DTPHS ) !-- Total ice
1675	!BSF QR=MAX(0.,MOIST(I,J,K,P_QR)+RQRBLTEN(I,K,J)*DTPHS )
1676	QR=MAX(0.,MOIST(I,J,K,P_QR) )
1677	MOIST(I,J,K,P_QC)=QW
1678	MOIST(I,J,K,P_QI)=QI
1679	MOIST(I,J,K,P_QR)=QR
1680	endif
1681	CWM(I,J,K)=QW+QI+QR
1682	!
1683	IF(QI<=EPSQ)THEN
1684	F_ICE(I,K,J)=0.
1685	ELSE
1686	F_ICE(I,K,J)=MAX(0.,MIN(1.,QI/CWM(I,J,K)))
1687	ENDIF
1688	!
1689	IF(QR<=EPSQ)THEN
1690	F_RAIN(I,K,J)=0.
1691	ELSE
1692	F_RAIN(I,K,J)=QR/(QW+QR)
1693	ENDIF
1694	!
1695	ENDIF !-- IF(CONFIG_FLAGS%MP_PHYSICS/=ETAMPNEW)THEN
1696	!
1697	Q2(I,J,K)=2.*TKE(I,K,J)
1698	ENDDO
1699	ENDDO
1700	!
1701	ENDDO
1702	!
1703	!-----------------------------------------------------------------------
1704	!***
1705	!*** SAVE SURFACE-RELATED FIELDS.
1706	!***
1707	!-----------------------------------------------------------------------
1708	!$omp parallel do &
1709	!$omp& private(i,j,llij,xlvrw)
1710	DO J=MYJS2,MYJE2
1711	DO I=MYIS1,MYIE1
1712	LLIJ=LOWLYR(I,J)
1713	!
1714	!-----------------------------------------------------------------------
1715	!*** INSTANTANEOUS SENSIBLE AND LATENT HEAT FLUX
1716	!-----------------------------------------------------------------------
1717	!
1718	TWBS(I,J)=-TWBS(I,J)
1719	QWBS(I,J)=-QWBS(I,J)XLVCHKLOWQ(I,J)
1720	!
1721	!-----------------------------------------------------------------------
1722	!*** ACCUMULATED QUANTITIES.
1723	!*** IN OPNL LSM, SFCEVP APPEARS TO BE IN UNITS OF
1724	!*** METERS OF LIQUID WATER. IT IS COMING FROM
1725	!* WRF MODULE AS KG/M2.
1726	!-----------------------------------------------------------------------
1727	!
1728	SFCSHX(I,J)=SFCSHX(I,J)+TWBS(I,J)
1729	SFCLHX(I,J)=SFCLHX(I,J)+QWBS(I,J)
1730	XLVRW=DTPHS/(XLV*RHOWATER)
1731	SFCEVP(I,J)=SFCEVP(I,J)-QWBS(I,J)*XLVRW
1732	POTEVP(I,J)=POTEVP(I,J)-QWBS(I,J)SM(I,J)XLVRW
1733	POTFLX(I,J)=POTEVP(I,J)*FACTOR
1734	SUBSHX(I,J)=SUBSHX(I,J)+GRNFLX(I,J)
1735	ENDDO
1736	ENDDO
1737	!
1738	!-----------------------------------------------------------------------
1739	!*** COUNTERS
1740	!-----------------------------------------------------------------------
1741	!
1742	APHTIM=APHTIM+1.
1743	ARDSW =ARDSW +1.
1744	ARDLW =ARDLW +1.
1745	ASRFC =ASRFC +1.
1746	!-----------------------------------------------------------------------
1747	!
1748	END SUBROUTINE TURBL
1749	!
1750	!-----------------------------------------------------------------------
1751	!***********************************************************************
1752	SUBROUTINE UV_H_TO_V(NTSD,DT,NPHS,UZ0H,VZ0H,UZ0,VZ0 &
1753	& ,DUDT,DVDT,U,V,HBM2,IVE,IVW &
1754	& ,IDS,IDE,JDS,JDE,KDS,KDE &
1755	& ,IMS,IME,JMS,JME,KMS,KME &
1756	& ,ITS,ITE,JTS,JTE,KTS,KTE)
1757	!***********************************************************************
1758	!$$$ SUBPROGRAM DOCUMENTATION BLOCK
1759	! . . .
1760	! SUBPROGRAM: UV_H_TO_V INTERPOLATE WINDS FROM H TO V POINTS
1761	! PRGRMMR: BLACK ORG: W/NP22 DATE: 05-02-22
1762	!
1763	! ABSTRACT:
1764	! INTERPOLATE WINDS BACK TO V POINTS AFTER TURBULENCE
1765	!
1766	! PROGRAM HISTORY LOG :
1767	! 05-02-22 BLACK - ORIGINATOR
1768	! 05-12-12 BLACK - CONVERTED FROM IKJ TO IJK
1769	!
1770	! USAGE: CALL TURBL FROM SOLVE_NMM
1771	!
1772	! ATTRIBUTES:
1773	! LANGUAGE: FORTRAN 90
1774	! MACHINE : IBM
1775	!$$$
1776	!-----------------------------------------------------------------------
1777	!
1778	IMPLICIT NONE
1779	!
1780	!-----------------------------------------------------------------------
1781	!
1782	INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
1783	& ,IMS,IME,JMS,JME,KMS,KME &
1784	& ,ITS,ITE,JTS,JTE,KTS,KTE &
1785	& ,NPHS,NTSD
1786	!
1787	INTEGER, DIMENSION(JMS:JME),INTENT(IN) :: IVE,IVW
1788	!
1789	REAL,INTENT(IN) :: DT
1790	!
1791	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: HBM2,UZ0H,VZ0H
1792	!
1793	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: DUDT,DVDT
1794	!
1795	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: UZ0,VZ0
1796	!
1797	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: U,V
1798	!
1799	!-----------------------------------------------------------------------
1800	!***
1801	!*** LOCAL VARIABLES
1802	!***
1803	!-----------------------------------------------------------------------
1804	!
1805	INTEGER :: I,IEND,J,K
1806	!
1807	REAL :: DTPHS
1808	!
1809	LOGICAL :: E_BDY
1810	!
1811	!-----------------------------------------------------------------------
1812	!-----------------------------------------------------------------------
1813	!
1814	DTPHS=NPHS*DT
1815	E_BDY=(ITE>=IDE)
1816	!
1817	!-----------------------------------------------------------------------
1818	!*** RECONSTRUCT UZ0 AND VZ0 ON VELOCITY POINTS.
1819	!-----------------------------------------------------------------------
1820	!
1821	!$omp parallel do &
1822	!$omp& private(i,j)
1823	DO J=MYJS2,MYJE2
1824	DO I=MYIS,MYIE
1825	UZ0(I,J)=(UZ0H(I+IVE(J),J)*HBM2(I+IVE(J),J) &
1826	& +UZ0H(I+IVW(J),J)*HBM2(I+IVW(J),J) &
1827	& +UZ0H(I,J+1)HBM2(I,J+1)+UZ0H(I,J-1)HBM2(I,J-1))*0.25
1828	VZ0(I,J)=(VZ0H(I+IVE(J),J)*HBM2(I+IVE(J),J) &
1829	& +VZ0H(I+IVW(J),J)*HBM2(I+IVW(J),J) &
1830	& +VZ0H(I,J+1)HBM2(I,J+1)+VZ0H(I,J-1)HBM2(I,J-1))*0.25
1831	ENDDO
1832	ENDDO
1833	!
1834	!-----------------------------------------------------------------------
1835	!*** INTERPOLATE WIND TENDENCIES TO VELOCITY POINTS AND UPDATE WINDS.
1836	!-----------------------------------------------------------------------
1837	!
1838	!$omp parallel do &
1839	!$omp& private(i,iend,j,k)
1840	DO K=KTS,KTE
1841	DO J=MYJS2,MYJE2
1842	IEND=MYIE1
1843	IF(E_BDY.AND.MOD(J,2)==1)IEND=IEND-1
1844	!
1845	DO I=MYIS1,IEND
1846	U(I,J,K)=(DUDT(I+IVE(J),J,K)+DUDT(I+IVW(J),J,K) &
1847	& +DUDT(I,J+1,K)+DUDT(I,J-1,K))0.25DTPHS &
1848	& +U(I,J,K)
1849	V(I,J,K)=(DVDT(I+IVE(J),J,K)+DVDT(I+IVW(J),J,K) &
1850	& +DVDT(I,J+1,K)+DVDT(I,J-1,K))0.25DTPHS &
1851	& +V(I,J,K)
1852	ENDDO
1853	ENDDO
1854	ENDDO
1855	!-----------------------------------------------------------------------
1856	!
1857	END SUBROUTINE UV_H_TO_V
1858	!
1859	!-----------------------------------------------------------------------
1860	!***********************************************************************
1861	!-----------------------------------------------------------------------
1862	SUBROUTINE CUCNVC(NTSD,DT,NCNVC,NRADS,NRADL &
1863	& ,GPS,RESTRT,HYDRO &
1864	& ,CLDEFI,N_MOIST,ENSDIM &
1865	& ,MOIST &
1866	& ,DETA1,DETA2,AETA1,AETA2,ETA1,ETA2 &
1867	& ,F_ICE,F_RAIN &
1868	!*** Changes for other cu-schemes, most for gd scheme
1869	& ,APR_GR,APR_W,APR_MC,TTEN,QTEN &
1870	& ,APR_ST,APR_AS,APR_CAPMA &
1871	& ,APR_CAPME ,APR_CAPMI &
1872	& ,MASS_FLUX ,XF_ENS &
1873	& ,PR_ENS,GSW &
1874	#ifdef WRF_CHEM
1875	& ,GD_CLOUD,GD_CLOUD2,RAINCV &
1876	#endif
1877	!
1878	& ,PDTOP,PT,PD,RES,PINT,T,Q,CWM,TCUCN &
1879	& ,OMGALF,U,V,W,Z,FIS,W0AVG &
1880	& ,PREC,ACPREC,CUPREC,CUPPT,CPRATE &
1881	& ,SM,HBM2,LPBL,CNVBOT,CNVTOP &
1882	& ,HTOP,HBOT,HTOPD,HBOTD,HTOPS,HBOTS &
1883	& ,RTHBLTEN,RQVBLTEN,RTHRATEN &
1884	#if (NMM_CORE==1)
1885	& ,DUCUDT, DVCUDT, MOMMIX, store_rand &
1886	#endif
1887	& ,AVCNVC,ACUTIM,IHE,IHW &
1888	& ,GRID,CONFIG_FLAGS &
1889	& ,NRND1 & ! NRND1 for random no restart
1890	& ,IDS,IDE,JDS,JDE,KDS,KDE &
1891	& ,IMS,IME,JMS,JME,KMS,KME &
1892	& ,IPS,IPE,JPS,JPE,KPS,KPE &
1893	& ,ITS,ITE,JTS,JTE,KTS,KTE)
1894	!***********************************************************************
1895	!$$$ SUBPROGRAM DOCUMENTATION BLOCK
1896	! . . .
1897	! SUBPROGRAM: CUCNVC CONVECTIVE PRECIPITATION OUTER DRIVER
1898	! PRGRMMR: BLACK ORG: W/NP22 DATE: 02-03-21
1899	!
1900	! ABSTRACT:
1901	! CUCVNC DRIVES THE WRF CONVECTION SCHEMES
1902	!
1903	! PROGRAM HISTORY LOG:
1904	! 02-03-21 BLACK - ORIGINATOR
1905	! 04-11-18 BLACK - THREADED
1906	! 05-12-15 BLACK - CONVERTED FROM IKJ TO IJK
1907	!
1908	! USAGE: CALL CUCNVC FROM SOLVE_NMM
1909	!
1910	! ATTRIBUTES:
1911	! LANGUAGE: FORTRAN 90
1912	! MACHINE : IBM
1913	!$$$
1914	!-----------------------------------------------------------------------
1915	!
1916	IMPLICIT NONE
1917	!
1918	!-----------------------------------------------------------------------
1919	!
1920	INTEGER,INTENT(IN) :: ENSDIM &
1921	& ,IDS,IDE,JDS,JDE,KDS,KDE &
1922	& ,IMS,IME,JMS,JME,KMS,KME &
1923	& ,IPS,IPE,JPS,JPE,KPS,KPE &
1924	& ,ITS,ITE,JTS,JTE,KTS,KTE &
1925	& ,N_MOIST,NCNVC,NTSD,NRADS,NRADL
1926	!
1927	INTEGER, DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW
1928	!
1929	INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: LPBL
1930	!
1931	REAL,INTENT(IN) :: DT,GPS,PDTOP,PT
1932	!
1933	REAL,INTENT(INOUT) :: ACUTIM,AVCNVC
1934	!
1935	REAL,DIMENSION(KMS:KME-1),INTENT(IN) :: AETA1,AETA2,DETA1,DETA2
1936	REAL,DIMENSION(KMS:KME ),INTENT(IN) :: ETA1,ETA2
1937	!
1938	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: FIS,HBM2,PD,RES,SM
1939	!
1940	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: ACPREC,CLDEFI &
1941	& ,CNVBOT,CNVTOP &
1942	& ,CUPPT,CUPREC &
1943	& ,HBOT,HTOP &
1944	& ,HBOTD,HTOPD &
1945	& ,HBOTS,HTOPS &
1946	& ,PREC,CPRATE &
1947	& ,APR_GR,APR_W,APR_MC &
1948	& ,APR_ST,APR_AS,APR_CAPMA &
1949	& ,APR_CAPME,APR_CAPMI &
1950	& ,GSW,MASS_FLUX
1951	#if (NMM_CORE==1)
1952	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: store_rand
1953	#endif
1954	!
1955	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: F_ICE &
1956	& ,F_RAIN
1957	!
1958	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: QTEN &
1959	& ,RQVBLTEN &
1960	& ,RTHBLTEN &
1961	& ,RTHRATEN &
1962	& ,TTEN
1963	!
1964	#if (NMM_CORE==1)
1965	REAL, INTENT(INOUT)::MOMMIX
1966	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT):: DUCUDT, DVCUDT
1967	REAL,DIMENSION(IDS:IDE,JDS:JDE) :: DATA1
1968	LOGICAL, EXTERNAL::wrf_dm_on_monitor
1969	#endif
1970	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: CWM &
1971	& ,OMGALF &
1972	& ,Q,T &
1973	& ,TCUCN &
1974	& ,U,V &
1975	& ,W,Z
1976	!
1977	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: PINT
1978	!
1979	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: W0AVG
1980	!
1981	REAL,DIMENSION(IMS:IME,JMS:JME,1:ENSDIM),INTENT(INOUT) :: PR_ENS &
1982	& ,XF_ENS
1983	!
1984	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME,N_MOIST) &
1985	& ,INTENT(INOUT) :: MOIST
1986	!
1987	#ifdef WRF_CHEM
1988	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: GD_CLOUD &
1989	& ,GD_CLOUD2
1990	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: RAINCV
1991	#endif
1992	!
1993	LOGICAL,INTENT(IN) :: HYDRO,RESTRT
1994	!
1995	TYPE(DOMAIN),TARGET :: GRID
1996	!
1997	TYPE(GRID_CONFIG_REC_TYPE),INTENT(IN) :: CONFIG_FLAGS
1998	!
1999	!-----------------------------------------------------------------------
2000	!*** LOCAL VARIABLES
2001	!-----------------------------------------------------------------------
2002	!
2003	INTEGER :: I,ICLDCK,IENDX,ISTAT,J,K,MNTO,N,N_TIMSTPS_OUTPUT &
2004	& ,NCUBOT,NCUTOP,NSTEP_CNV
2005	!
2006	INTEGER,DIMENSION(IMS:IME,JMS:JME) :: KPBL,LBOT,LOWLYR,LTOP
2007	!
2008	REAL :: CAPA,CF_HI,DPL,DQDT,DTCNVC,DTDT,FICE,FRAIN,G_INV &
2009	& ,PCPCOL,PLYR,QI,QL_K,QR,QW,RDTCNVC,TL_K,WC,WMID
2010	!
2011	REAL,DIMENSION(KMS:KME-1) :: QL,TL
2012	!
2013	REAL,DIMENSION(IMS:IME,JMS:JME) :: CUBOT,CUTOP,NCA,PDSL &
2014	& ,RAINC,SFCZ,XLAND
2015	#ifndef WRF_CHEM
2016	REAL,DIMENSION(IMS:IME,JMS:JME) :: RAINCV
2017	#endif
2018	!
2019	REAL,DIMENSION(ITS:ITE,JTS:JTE) :: WMID_L
2020	!
2021	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: DZ,P8W,P_PHY,PI_PHY &
2022	& ,RQCCUTEN,RQRCUTEN &
2023	& ,RQICUTEN,RQSCUTEN &
2024	& ,RQVCUTEN,RR,RTHCUTEN &
2025	& ,T_PHY,TH_PHY &
2026	& ,U_PHY,V_PHY,WINT
2027	!
2028	REAL,DIMENSION(IMS:IME,JMS:JME,ENSDIM) :: ZERO_GD
2029	!
2030	REAL,DIMENSION(:,:,:,:),ALLOCATABLE :: MOIST_TRANS
2031	!
2032	LOGICAL :: RESTART,WARM_RAIN
2033	LOGICAL,DIMENSION(IMS:IME,JMS:JME) :: CU_ACT_FLAG
2034	!
2035	CHARACTER(LEN=255) :: message
2036	!
2037	!-----------------------------------------------------------------------
2038	!*** FOR TEMPERATURE CHANGE CHECK ONLY.
2039	!-----------------------------------------------------------------------
2040	INTEGER :: DTEMP_CHECK=2.0
2041	REAL :: TCHANGE
2042	! random number restart
2043	INTEGER,DIMENSION(:),INTENT(INOUT) :: NRND1
2044	INTEGER, SAVE :: nfirst
2045	data nfirst /0/
2046	#if (NMM_CORE==1)
2047	INTEGER :: IDT
2048	REAL, DIMENSION(2) :: RND1
2049	#endif
2050	!-----------------------------------------------------------------------
2051	!***********************************************************************
2052	!-----------------------------------------------------------------------
2053	!
2054	!-----------------------------------------------------------------------
2055	!*** RESET THE HBOT/HTOP CONVECTIVE CLOUD BOTTOM (BASE) AND TOP ARRAYS
2056	!*** USED IN RADIATION. THEY STORE THE MAXIMUM VERTICAL LIMITS OF
2057	!*** CONVECTIVE CLOUD BETWEEN RADIATION CALLS. CUPPT IS THE ACCUMULATED
2058	!*** CONVECTIVE PRECIPITATION BETWEEN RADIATION CALLS.
2059	!-----------------------------------------------------------------------
2060	!
2061	IF(MOD(NTSD,NRADS)==0.OR.MOD(NTSD,NRADL)==0)THEN
2062	DO J=JMS,JME
2063	DO I=IMS,IME
2064	HTOP(I,J)=0.
2065	HBOT(I,J)=REAL(KTE+1)
2066	CUTOP(I,J)=0.
2067	CUBOT(I,J)=REAL(KTE+1)
2068	CUPPT(I,J)=0.
2069	ENDDO
2070	ENDDO
2071	ENDIF
2072	!-----------------------------------------------------------------------
2073	IF(MOD(NTSD,NCNVC)/=0.AND. &
2074	& CONFIG_FLAGS%CU_PHYSICS==BMJSCHEME)RETURN
2075	IF(MOD(NTSD,NCNVC)/=0.AND. &
2076	& CONFIG_FLAGS%CU_PHYSICS==SASSCHEME)RETURN
2077
2078	!-----------------------------------------------------------------------
2079	NSTEP_CNV=NCNVC
2080	!
2081	RESTART=RESTRT
2082	!-----------------------------------------------------------------------
2083	IF(CONFIG_FLAGS%CU_PHYSICS==KFETASCHEME)THEN
2084	!
2085	IF(.NOT.RESTART.AND.NTSD==0)THEN
2086	!$omp parallel do &
2087	!$omp& private(i,j,k)
2088	DO J=JTS,JTE
2089	DO K=KTS,KTE
2090	DO I=ITS,ITE
2091	W0AVG(I,K,J)=0.
2092	ENDDO
2093	ENDDO
2094	ENDDO
2095	ENDIF
2096	!
2097	ENDIF
2098	!
2099	!-----------------------------------------------------------------------
2100	!*** GENERAL PREPARATION
2101	!-----------------------------------------------------------------------
2102	!
2103	AVCNVC=AVCNVC+1.
2104	ACUTIM=ACUTIM+1.
2105	!
2106	DTCNVC=NCNVC*DT
2107	RDTCNVC=1./DTCNVC
2108	CAPA=R_D/CP
2109	G_INV=1./G
2110	!
2111	!$omp parallel do &
2112	!$omp& private(I,J)
2113	DO J=MYJS2,MYJE2
2114	DO I=MYIS1,MYIE1
2115	!
2116	PDSL(I,J)=PD(I,J)*RES(I,J)
2117	RAINCV(I,J)=0.
2118	RAINC(I,J)=0.
2119	P8W(I,KTS,J)=PD(I,J)+PDTOP+PT
2120	LOWLYR(I,J)=KTS !<---- The lowest model layer counted from the bottom.
2121	XLAND(I,J)=SM(I,J)+1.
2122	NCA(I,J)=0.
2123	SFCZ(I,J)=FIS(I,J)*G_INV
2124	!
2125	CUTOP(I,J)=HTOP(I,J)
2126	CUBOT(I,J)=HBOT(I,J)
2127	!
2128	!*** LPBL IS THE MODEL LAYER CONTAINING THE PBL TOP
2129	!*** COUNTING DOWNWARD FROM THE TOP OF THE DOMAIN
2130	!*** SO KPBL IS THE SAME LAYER COUNTING UPWARD FROM
2131	!*** THE GROUND.
2132	!
2133	KPBL(I,J)=KTE-LPBL(I,J)+1
2134	ENDDO
2135	ENDDO
2136	!
2137	!$omp parallel do &
2138	!$omp& private(dpl,fice,frain,i,j,k,plyr,qi,ql,qr,qw,wc)
2139	DO J=MYJS2,MYJE2
2140	DO K=KTS,KTE
2141	DO I=MYIS1,MYIE1
2142	DPL=DETA1(K)PDTOP+DETA2(K)PDSL(I,J)
2143	QL(K)=MAX(Q(I,J,K),EPSQ)
2144	PLYR=AETA1(K)PDTOP+AETA2(K)PDSL(I,J)+PT
2145	TL(K)=T(I,J,K)
2146	!
2147	RR(I,K,J)=PLYR/(R_DTL(K)(P608*QL(K)+1.))
2148	T_PHY(I,K,J)=TL(K)
2149
2150	TH_PHY(I,K,J)=TL(K)(1.E5/PLYR)*CAPA
2151	!!! P8W(I,KFLIP,J)=PINT(I,J,K+1)
2152	P8W(I,K+1,J)=ETA1(K+1)PDTOP+ETA2(K+1)PDSL(I,J)+PT
2153	P_PHY(I,K,J)=PLYR
2154	PI_PHY(I,K,J)=(PLYR1.E-5)*CAPA
2155	!
2156	RTHCUTEN(I,K,J)=0.
2157	RQVCUTEN(I,K,J)=0.
2158	RQCCUTEN(I,K,J)=0.
2159	RQRCUTEN(I,K,J)=0.
2160	RQICUTEN(I,K,J)=0.
2161	RQSCUTEN(I,K,J)=0.
2162	ENDDO
2163	!
2164	ENDDO
2165	ENDDO
2166	!
2167	!-----------------------------------------------------------------------
2168	!
2169
2170	IF(.NOT.HYDRO)THEN
2171	!$omp parallel do &
2172	!$omp& private(i,j,k)
2173	DO K=KTS,KTE
2174	DO J=MYJS2,MYJE2
2175	DO I=MYIS1,MYIE1
2176	DZ(I,K,J)=Z(I,J,K+1)-Z(I,J,K)
2177	ENDDO
2178	ENDDO
2179	ENDDO
2180	!
2181	IF(NTSD==0)THEN
2182	!$omp parallel do &
2183	!$omp& private(i,j,k)
2184	DO J=MYJS2,MYJE2
2185	DO K=KTS,KTE+1 ! zero for all interfaces
2186	DO I=MYIS1,MYIE1
2187	WINT(I,K,J)=0.
2188	ENDDO
2189	ENDDO
2190	ENDDO
2191
2192	ELSE ! not NTSD=0
2193
2194	DO J=MYJS2,MYJE2
2195	DO I=MYIS1,MYIE1
2196	WINT(I,KTS,J)=0.
2197	WINT(I,KTE+1,J)=0.
2198	ENDDO
2199	ENDDO
2200
2201	DO J=MYJS2,MYJE2
2202	DO K=KTS+1,KTE
2203	DO I=MYIS1,MYIE1
2204	WINT(I,K,J)=0.5*(W(I,J,K)+W(I,J,K-1))
2205	ENDDO
2206	ENDDO
2207	ENDDO
2208
2209	ENDIF
2210
2211	ELSE ! hydrostatic
2212
2213	DO J=MYJS2,MYJE2
2214	DO I=MYIS1,MYIE1
2215	WINT(I,KTS,J)=0.
2216	WINT(I,KTE+1,J)=0.
2217	ENDDO
2218	ENDDO
2219	!
2220	!$omp parallel do &
2221	!$omp& private(i,j,k,plyr)
2222	DO J=MYJS2,MYJE2
2223	DO I=MYIS1,MYIE1
2224	WMID_L(I,J)=-OMGALF(I,J,KTS)CP/(GDT)
2225	PDSL(I,J)=PD(I,J)*RES(I,J)
2226	PLYR=AETA1(KTS)PDTOP+AETA2(KTS)PDSL(I,J)+PT
2227	DZ(I,KTS,J)=T(I,J,KTS)(P608Q(I,J,KTS)+1.)*R_D &
2228	& *(P8W(I,KTS,J)-P8W(I,KTS+1,J)) &
2229	& /(PLYR*G)
2230	ENDDO
2231	ENDDO
2232	!
2233	!$omp parallel do &
2234	!$omp& private(i,j,k,ql_k,tl_k,wmid)
2235	DO J=MYJS2,MYJE2
2236	DO K=KTS+1,KTE
2237	DO I=MYIS1,MYIE1
2238	TL_K=T_PHY(I,K,J)
2239	QL_K=MAX(Q(I,J,K),EPSQ)
2240	WMID=-OMGALF(I,J,K)CP/(GDT)
2241	WINT(I,K,J)=0.5*(WMID_L(I,J)+WMID)
2242	WMID_L(I,J)=WMID
2243	DZ(I,K,J)=TL_K(P608QL_K+1.)*R_D &
2244	& *(P8W(I,K,J)-P8W(I,K+1,J)) &
2245	& /(P_PHY(I,K,J)*G)
2246	ENDDO
2247	ENDDO
2248	ENDDO
2249	!
2250	ENDIF
2251	!
2252	!-----------------------------------------------------------------------
2253	!*** COMPUTE VELOCITY COMPONENTS AT MASS POINTS
2254	!-----------------------------------------------------------------------
2255	!
2256	IF(CONFIG_FLAGS%CU_PHYSICS/=BMJSCHEME)THEN
2257	!
2258	!$omp parallel do &
2259	!$omp& private(i,j,k)
2260	DO K=KTS,KTE
2261	!
2262	DO J=MYJS1_P1,MYJE1_P1
2263	DO I=MYIS_P1,MYIE_P1
2264	U_PHY(I,K,J)=(U(I+IHE(J),J,K)+U(I+IHW(J),J,K) &
2265	& +U(I,J+1,K)+U(I,J-1,K)) &
2266	& *0.25
2267	V_PHY(I,K,J)=(V(I+IHE(J),J,K)+V(I+IHW(J),J,K) &
2268	& +V(I,J+1,K)+V(I,J-1,K)) &
2269	& *0.25
2270	ENDDO
2271	ENDDO
2272	!
2273	ENDDO
2274	!
2275	ENDIF
2276	!
2277	!-----------------------------------------------------------------------
2278	!*** TRANSPOSE THE MOIST ARRAY (IJK) FOR THE PHYSICS (IKJ).
2279	!-----------------------------------------------------------------------
2280	!
2281	IF(.NOT.ALLOCATED(MOIST_TRANS))THEN
2282	ALLOCATE(MOIST_TRANS(IMS:IME,KMS:KME,JMS:JME,N_MOIST),STAT=ISTAT)
2283	ENDIF
2284	!
2285	DO N=1,N_MOIST
2286	!$omp parallel do &
2287	!$omp& private(i,j,k)
2288	DO K=KMS,KME
2289	DO J=JMS,JME
2290	DO I=IMS,IME
2291	MOIST_TRANS(I,K,J,N)=MOIST(I,J,K,N)
2292	ENDDO
2293	ENDDO
2294	ENDDO
2295	ENDDO
2296
2297
2298	CALL SET_TILES(GRID,IDS+1,IDE-1,JDS+2,JDE-2,ITS,ITE,JTS,JTE)
2299	#if (NMM_CORE==1)
2300	!#ifdef HWRF
2301	!
2302	!-----------------------------------------------------------------------
2303	!
2304	! SAS CONVECTION NEEDS RANDOM NUMBER WHICH IS STORED HERE FOR
2305	! EACH OF THE DOMAIN AND THEN THEY ARE PASSED ON INTO THE
2306	! CUMULUS DRIVER. THIS IS gopal's doing
2307	!
2308
2309	IF(CONFIG_FLAGS%CU_PHYSICS==SASSCHEME)THEN
2310	!
2311	IF(GRID%ID .EQ. 1)THEN ! Both parent and nest set to 5 minutes for random number calls
2312	IDT=MOD(NTSD,NCNVC)
2313	ELSE
2314	IDT=MOD(NTSD,5*NCNVC)
2315	ENDIF
2316
2317	IF(IDT.EQ.0 .OR. NTSD .EQ. 0)THEN
2318	!$omp parallel do &
2319	!$omp& private(i,j)
2320	IF (wrf_dm_on_monitor()) THEN !!!! For bit reproducibility of random numbers
2321	if (restart .and. nfirst .eq. 0 ) then
2322	call random_seed(put=nrnd1)
2323	nfirst=1
2324	endif
2325	call random_seed(get=nrnd1)
2326	DO J=JDS,JDE !JTS,JTE
2327	DO I=IDS,IDE !ITS,ITE
2328	CALL RANDOM_NUMBER(rnd1)
2329	DATA1(I,J)=rnd1(2)
2330	ENDDO
2331	ENDDO
2332	ENDIF
2333	CALL wrf_dm_bcast_bytes (DATA1,IDEJDERWORDSIZE) !!! broadcast random nos. to other processors
2334
2335	DO J=JDS,JDE
2336	DO I =IDS,IDE
2337	IF(I.GE.ITS .AND. I .LE. MIN(ide,ite) .AND. J.GE.JTS .AND. J .LE. MIN(jde,jte))THEN
2338	STORE_RAND(I,J)=DATA1(I,J)
2339	ENDIF
2340	ENDDO
2341	ENDDO
2342	!
2343	ENDIF ! for IF(IDT.EQ.0 .OR. NTSD .EQ. 0)
2344	!
2345	ELSE
2346	!jm STORE_RAND(I,J) = 0.0
2347	STORE_RAND = 0.0
2348	ENDIF
2349
2350	!$omp parallel do &
2351	!$omp& private(i,j,k)
2352	DO K=KMS,KME
2353	DO J=JMS,JME
2354	DO I=IMS,IME
2355	DUCUDT(i,j,k)=0.0
2356	DVCUDT(i,j,k)=0.0
2357	ENDDO
2358	ENDDO
2359	ENDDO
2360	!#endif
2361	#endif
2362	CALL CUMULUS_DRIVER(GRID &
2363	& ,IDS=IDS,IDE=IDE,JDS=JDS,JDE=JDE,KDS=KDS,KDE=KDE &
2364	& ,IMS=IMS,IME=IME,JMS=JMS,JME=JME,KMS=KMS,KME=KME &
2365	& ,IPS=ips,IPE=ipe,JPS=jps,JPE=jpe,KPS=kps,KPE=kpe &
2366	& ,I_START=GRID%I_START,I_END=GRID%I_END &
2367	& ,J_START=GRID%J_START,J_END=GRID%J_END &
2368	& ,KTS=KTS,KTE=KTE,NUM_TILES=GRID%NUM_TILES &
2369	! Prognostic
2370	& ,U=U_PHY,V=V_PHY,TH=TH_PHY,T=T_PHY,W=WINT &
2371	& ,P=P_PHY,PI=PI_PHY,RHO=RR,W0AVG=W0AVG &
2372	! Others
2373	& ,ITIMESTEP=NTSD,DT=DT,DX=GPS &
2374	& ,RAINC=RAINC,RAINCV=RAINCV,NCA=NCA &
2375	& ,DZ8W=DZ,P8W=P8W,FORCET=TTEN,FORCEQ=QTEN &
2376	& ,CLDEFI=CLDEFI,LOWLYR=LOWLYR,XLAND=XLAND &
2377	& ,CU_ACT_FLAG=CU_ACT_FLAG,WARM_RAIN=WARM_RAIN &
2378	& ,STEPCU=NSTEP_CNV,GSW=GSW &
2379	& ,PERIODIC_X=.FALSE.,PERIODIC_Y=.FALSE. &
2380	& ,HTOP=CUTOP,HBOT=CUBOT,KPBL=KPBL,HT=SFCZ,Z=Z &
2381	& ,APR_GR=APR_GR,APR_W=APR_W,APR_MC=APR_MC &
2382	& ,APR_ST=APR_ST,APR_AS=APR_AS,APR_CAPMA=APR_CAPMA &
2383	& ,APR_CAPME=APR_CAPME,APR_CAPMI=APR_CAPMI &
2384	& ,MASS_FLUX=MASS_FLUX,XF_ENS=XF_ENS &
2385	& ,PR_ENS=PR_ENS &
2386	#ifdef WRF_CHEM
2387	& ,GD_CLOUD=GD_CLOUD,GD_CLOUD2=GD_CLOUD2 &
2388	#endif
2389
2390	& ,ENSDIM=ENSDIM,MAXIENS=1,MAXENS=3 &
2391	& ,MAXENS2=3,MAXENS3=16 &
2392	& ,RTHCUTEN=RTHCUTEN,RQVCUTEN=RQVCUTEN &
2393	& ,RQCCUTEN=RQCCUTEN,RQRCUTEN=RQRCUTEN &
2394	& ,RQICUTEN=RQICUTEN,RQSCUTEN=RQSCUTEN &
2395	& ,RTHBLTEN=RTHBLTEN,RQVBLTEN=RQVBLTEN &
2396	& ,RTHRATEN=RTHRATEN &
2397	#if (NMM_CORE==1)
2398	& ,RUCUTEN=DUCUDT, RVCUTEN=DVCUDT, MOMMIX=MOMMIX &
2399	,store_rand=store_rand &
2400	#endif
2401	! Selection argument
2402	& ,CU_PHYSICS=CONFIG_FLAGS%CU_PHYSICS &
2403	! Moisture tracer arguments
2404	& ,QV_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QV),F_QV=F_QV &
2405	& ,QC_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QC),F_QC=F_QC &
2406	& ,QR_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QR),F_QR=F_QR &
2407	& ,QI_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QI),F_QI=F_QI &
2408	& ,QS_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QS),F_QS=F_QS &
2409	& ,QG_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QG),F_QG=F_QG)
2410	!
2411	!-----------------------------------------------------------------------
2412	!
2413	!*** CNVTOP/CNVBOT HOLD THE MAXIMUM VERTICAL LIMITS OF CONVECTIVE CLOUD
2414	!*** BETWEEN HISTORY OUTPUT TIMES. HBOTS/HTOPS STORE SIMILIAR INFORMATION
2415	!*** FOR SHALLOW (NONPRECIPITATING) CONVECTION, AND HBOTD/HTOPD ARE FOR
2416	!*** DEEP (PRECIPITATING) CONVECTION.
2417	!
2418	CF_HI=CONFIG_FLAGS%HISTORY_INTERVAL
2419	N_TIMSTPS_OUTPUT=NINT(60.*CF_HI/DT)
2420	MNTO=MOD(NTSD,N_TIMSTPS_OUTPUT)
2421	!
2422	IF(MNTO>0.AND.MNTO<=NCNVC)THEN
2423	DO J=MYJS2,MYJE2
2424	IENDX=MYIE1
2425	IF(MOD(J,2)==0.AND.ITE==IDE-1)IENDX=IENDX-1
2426	DO I=MYIS1,IENDX
2427	CNVBOT(I,J)=REAL(KTE+1.)
2428	CNVTOP(I,J)=0.
2429	HBOTD(I,J)=REAL(KTE+1.)
2430	HTOPD(I,J)=0.
2431	HBOTS(I,J)=REAL(KTE+1.)
2432	HTOPS(I,J)=0.
2433	ENDDO
2434	ENDDO
2435	ENDIF
2436	!
2437	!-----------------------------------------------------------------------
2438	!
2439	!$omp parallel do &
2440	!$omp& private(i,iendx,j,ncubot,ncutop,pcpcol)
2441	pcp_cloud: DO J=MYJS2,MYJE2
2442	IENDX=MYIE1
2443	IF(MOD(J,2)==0.AND.ITE==IDE-1)IENDX=IENDX-1
2444	DO I=MYIS1,IENDX
2445	!
2446	!*** UPDATE PRECIPITATION
2447	!
2448	PCPCOL=RAINCV(I,J)1.E-3NSTEP_CNV
2449	PREC(I,J)=PREC(I,J)+PCPCOL
2450	ACPREC(I,J)=ACPREC(I,J)+PCPCOL
2451	CUPREC(I,J)=CUPREC(I,J)+PCPCOL
2452	CUPPT(I,J)=CUPPT(I,J)+PCPCOL
2453	CPRATE(I,J)=PCPCOL
2454	!
2455	!*** SAVE CLOUD TOP AND BOTTOM FOR RADIATION (HTOP/HBOT) AND
2456	!*** FOR OUTPUT (CNVTOP/CNVBOT, HTOPS/HBOTS, HTOPD/HBOTD) ARRAYS.
2457	!*** THEY MUST BE TREATED SEPARATELY FROM EACH OTHER.
2458	!
2459	CUTOP(I,J)=MIN(CUTOP(I,J),REAL(KDE))
2460	CUTOP(I,J)=MAX(CUTOP(I,J),0.0)
2461	CUBOT(I,J)=MIN(CUBOT(I,J),REAL(KDE))
2462	CUBOT(I,J)=MAX(CUBOT(I,J),0.0)
2463
2464	NCUTOP=NINT(CUTOP(I,J))
2465	NCUBOT=NINT(CUBOT(I,J))
2466	!
2467	IF(NCUTOP>1.AND.NCUTOP<KDE)THEN
2468	HTOP(I,J)=MAX(CUTOP(I,J),HTOP(I,J))
2469	CNVTOP(I,J)=MAX(CUTOP(I,J),CNVTOP(I,J))
2470	IF(PCPCOL>0.)THEN
2471	HTOPD(I,J)=MAX(CUTOP(I,J),HTOPD(I,J))
2472	ELSE
2473	HTOPS(I,J)=MAX(CUTOP(I,J),HTOPS(I,J))
2474	ENDIF
2475	ENDIF
2476	!
2477	IF(NCUBOT>0.AND.NCUBOT<KDE)THEN
2478	HBOT(I,J)=MIN(CUBOT(I,J),HBOT(I,J))
2479	CNVBOT(I,J)=MIN(CUBOT(I,J),CNVBOT(I,J))
2480	IF(PCPCOL>0.)THEN
2481	HBOTD(I,J)=MIN(CUBOT(I,J),HBOTD(I,J))
2482	ELSE
2483	HBOTS(I,J)=MIN(CUBOT(I,J),HBOTS(I,J))
2484	ENDIF
2485	ENDIF
2486	!
2487	ENDDO
2488	ENDDO pcp_cloud
2489	!
2490	!-----------------------------------------------------------------------
2491	!*** UPDATE TEMPERATURE, SPECIFIC HUMIDITY, AND HEATING.
2492	!-----------------------------------------------------------------------
2493	!
2494	!$omp parallel do &
2495	!$omp& private(dqdt,dtdt,i,iendx,j,k,tchange)
2496	DO K=KTS,KTE
2497	DO J=MYJS2,MYJE2
2498	IENDX=MYIE1
2499	IF(MOD(J,2)==0.AND.ITE==IDE-1)IENDX=IENDX-1
2500	DO I=MYIS1,IENDX
2501	!
2502	!*** RQVCUTEN IN BMJDRV IS THE MIXING RATIO TENDENCY,
2503	!*** SO RETRIEVE DQDT BY CONVERTING TO SPECIFIC HUMIDITY.
2504	!
2505	DQDT=RQVCUTEN(I,K,J)/(1.+MOIST_TRANS(I,K,J,P_QV))**2
2506	!
2507	!*** RTHCUTEN IN BMJDRV IS DTDT OVER PI.
2508	!
2509	DTDT=RTHCUTEN(I,K,J)*PI_PHY(I,K,J)
2510	T(I,J,K)=T(I,J,K)+DTDT*DTCNVC
2511	Q(I,J,K)=Q(I,J,K)+DQDT*DTCNVC
2512	TCUCN(I,J,K)=TCUCN(I,J,K)+DTDT
2513	MOIST_TRANS(I,K,J,P_QV)=Q(I,J,K)/(1.-Q(I,J,K)) !Convert to mixing ratio
2514	!
2515	cps_select: SELECT CASE(config_flags%cu_physics)
2516	!
2517	CASE (KFSCHEME,KFETASCHEME,GDSCHEME,SASSCHEME)
2518	IF(CONFIG_FLAGS%MP_PHYSICS==ETAMPNEW)THEN
2519	MOIST_TRANS(I,K,J,P_QS)=MAX(0.,MOIST_TRANS(I,K,J,P_QS)+RQICUTEN(I,K,J)DTCNVC+RQSCUTEN(I,K,J)DTCNVC)
2520	ELSE
2521	MOIST_TRANS(I,K,J,P_QI)=MAX(0.,MOIST_TRANS(I,K,J,P_QI)+RQICUTEN(I,K,J)*DTCNVC)
2522	MOIST_TRANS(I,K,J,P_QS)=MAX(0.,MOIST_TRANS(I,K,J,P_QS)+RQSCUTEN(I,K,J)*DTCNVC)
2523	ENDIF
2524	MOIST_TRANS(I,K,J,P_QR)=MAX(0.,MOIST_TRANS(I,K,J,P_QR)+RQRCUTEN(I,K,J)*DTCNVC)
2525	MOIST_TRANS(I,K,J,P_QC)=MAX(0.,MOIST_TRANS(I,K,J,P_QC)+RQCCUTEN(I,K,J)*DTCNVC)
2526	END SELECT cps_select
2527	!
2528	TCHANGE=DTDT*DTCNVC
2529	IF(ABS(TCHANGE)>DTEMP_CHECK)THEN
2530	WRITE(message,*)'BIG T CHANGE BY CONVECTION=',TCHANGE &
2531	,' AT (',I,',',J,',',K,') FOR NTSD=',NTSD
2532	CALL wrf_message(trim(message))
2533	ENDIF
2534	!
2535	ENDDO
2536	ENDDO
2537	ENDDO
2538	!-----------------------------------------------------------------------
2539	!*** REFILL THE MOIST ARRAY.
2540	!-----------------------------------------------------------------------
2541	!
2542	DO N=1,N_MOIST
2543	!$omp parallel do &
2544	!$omp& private(i,j,k)
2545	DO J=JMS,JME
2546	DO K=KMS,KME
2547	DO I=IMS,IME
2548	MOIST(I,J,K,N)=MOIST_TRANS(I,K,J,N)
2549	ENDDO
2550	ENDDO
2551	ENDDO
2552	ENDDO
2553	!
2554	!-----------------------------------------------------------------------
2555	!
2556	DEALLOCATE(MOIST_TRANS,STAT=ISTAT)
2557	!
2558	!-----------------------------------------------------------------------
2559	!
2560	END SUBROUTINE CUCNVC
2561	!
2562	!-----------------------------------------------------------------------
2563	!***********************************************************************
2564	SUBROUTINE GSMDRIVE(NTSD,DT,NPHS,N_MOIST &
2565	& ,DX,DY,SM,HBM2,FIS &
2566	& ,DETA1,DETA2,AETA1,AETA2,ETA1,ETA2 &
2567	& ,PDTOP,PT,PD,RES,PINT,T,Q,CWM,TRAIN &
2568	& ,MOIST,SCALAR,N_SCALAR &
2569	& ,F_ICE,F_RAIN,F_RIMEF,SR &
2570	& ,PREC,ACPREC,AVRAIN &
2571	& ,MP_RESTART_STATE &
2572	& ,TBPVS_STATE &
2573	& ,TBPVS0_STATE &
2574	& ,GRID,CONFIG_FLAGS &
2575	& ,IDS,IDE,JDS,JDE,KDS,KDE &
2576	& ,IMS,IME,JMS,JME,KMS,KME &
2577	& ,ITS,ITE,JTS,JTE,KTS,KTE)
2578	!***********************************************************************
2579	!$$$ SUBPROGRAM DOCUMENTATION BLOCK
2580	! . . .
2581	! SUBPROGRAM: GSMDRIVE MICROPHYSICS OUTER DRIVER
2582	! PRGRMMR: BLACK ORG: W/NP22 DATE: 02-03-26
2583	!
2584	! ABSTRACT:
2585	! GSMDRIVE DRIVES THE MICROPHYSICS SCHEMES
2586	!
2587	! PROGRAM HISTORY LOG:
2588	! 02-03-26 BLACK - ORIGINATOR
2589	! 04-11-18 BLACK - THREADED
2590	! 05-12-19 BLACK - CONVERTED FROM IKJ TO IJK
2591	!
2592	! USAGE: CALL GSMDRIVE FROM SOLVE_NMM
2593	!
2594	! ATTRIBUTES:
2595	! LANGUAGE: FORTRAN 90
2596	! MACHINE : IBM
2597	!$$$
2598	!-----------------------------------------------------------------------
2599	!
2600	IMPLICIT NONE
2601	!
2602	!-----------------------------------------------------------------------
2603	!
2604	INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
2605	& ,IMS,IME,JMS,JME,KMS,KME &
2606	& ,ITS,ITE,JTS,JTE,KTS,KTE &
2607	& ,N_MOIST,N_SCALAR,NPHS,NTSD
2608	!
2609	REAL,INTENT(IN) :: DT,DX,DY,PDTOP,PT
2610	!
2611	REAL,INTENT(INOUT) :: AVRAIN
2612	!
2613	REAL,DIMENSION(KMS:KME-1),INTENT(IN) :: AETA1,AETA2,DETA1,DETA2
2614	REAL,DIMENSION(KMS:KME),INTENT(IN) :: ETA1,ETA2
2615	!
2616	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: FIS,HBM2,PD,RES,SM
2617	!
2618	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: PINT
2619	!
2620	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: ACPREC,PREC
2621	!
2622	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: CWM,Q &
2623	& ,T,TRAIN
2624	!
2625	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: F_ICE & !<--- Used only with physics (IKJ)
2626	& ,F_RAIN &
2627	& ,F_RIMEF
2628
2629	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME,N_MOIST) &
2630	& ,INTENT(INOUT) :: MOIST
2631	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME,N_SCALAR) &
2632	& ,INTENT(INOUT) :: SCALAR
2633	!
2634	!*** State var for etampnew microphysics (JM, 2005 05 02)
2635	!
2636	REAL,DIMENSION(:),INTENT(INOUT) :: MP_RESTART_STATE &
2637	& ,TBPVS_STATE,TBPVS0_STATE
2638	!
2639	REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: SR
2640	!
2641	TYPE(DOMAIN),TARGET :: GRID
2642	!
2643	TYPE(GRID_CONFIG_REC_TYPE),INTENT(IN) :: CONFIG_FLAGS
2644	!
2645	!-----------------------------------------------------------------------
2646	!*** LOCAL VARIABLES
2647	!-----------------------------------------------------------------------
2648	!
2649	INTEGER :: I,IENDX,IJ,ISTAT,J,K,N
2650	!
2651	INTEGER,DIMENSION(IMS:IME,JMS:JME) :: LOWLYR
2652	!
2653	REAL :: CAPA,DPL,DTPHS,PCPCOL,PLYR,RDTPHS,RG,TNEW
2654	!
2655	REAL,DIMENSION(KMS:KME-1) :: QL,TL
2656	!
2657	REAL,DIMENSION(IMS:IME,JMS:JME) :: CUBOT,CUTOP,PDSL &
2658	& ,RAINNC,RAINNCV,XLAND
2659	!
2660	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: CWM_PHY,DZ &
2661	& ,P8W,P_PHY,PI_PHY &
2662	& ,RR,T_PHY,TH_PHY
2663	!
2664	REAL,DIMENSION(:,:,:,:),ALLOCATABLE :: MOIST_TRANS
2665	REAL,DIMENSION(:,:,:,:),ALLOCATABLE :: SCALAR_TRANS
2666	!
2667	LOGICAL :: E_BDY,F_QT,QT_PRESENT,WARM_RAIN
2668	!
2669	!-----------------------------------------------------------------------
2670	!***********************************************************************
2671	!-----------------------------------------------------------------------
2672	!
2673	ALLOCATE(MOIST_TRANS(IMS:IME,KMS:KME,JMS:JME,N_MOIST),STAT=ISTAT)
2674	ALLOCATE(SCALAR_TRANS(IMS:IME,KMS:KME,JMS:JME,N_SCALAR),STAT=ISTAT)
2675	!
2676	!-----------------------------------------------------------------------
2677	!*** TRANSPOSE THE MOIST ARRAY (IJK) FOR THE PHYSICS (IKJ).
2678	!-----------------------------------------------------------------------
2679	!
2680	DO N=1,N_MOIST
2681	!$omp parallel do &
2682	!$omp& private(i,j,k)
2683	DO K=KMS,KME
2684	DO J=JMS,JME
2685	DO I=IMS,IME
2686	MOIST_TRANS(I,K,J,N)=MOIST(I,J,K,N)
2687	ENDDO
2688	ENDDO
2689	ENDDO
2690	ENDDO
2691	!
2692	!-----------------------------------------------------------------------
2693	!
2694	IF(CONFIG_FLAGS%MP_PHYSICS/=ETAMPNEW.and.config_flags%mp_physics/=etamp_hwrf)THEN
2695	DO N=1,N_SCALAR
2696	!$omp parallel do &
2697	!$omp& private(i,j,k)
2698	DO K=KMS,KME
2699	DO J=JMS,JME
2700	DO I=IMS,IME
2701	SCALAR_TRANS(I,K,J,N)=SCALAR(I,J,K,N)
2702	ENDDO
2703	ENDDO
2704	ENDDO
2705	ENDDO
2706	ENDIF
2707	!
2708	!-----------------------------------------------------------------------
2709	!
2710	IF(CONFIG_FLAGS%MP_PHYSICS==ETAMPNEW.or.config_flags%mp_physics==etamp_hwrf)THEN
2711	QT_PRESENT=.TRUE.
2712	ELSE
2713	QT_PRESENT=.FALSE.
2714	ENDIF
2715	!
2716	DTPHS=NPHS*DT
2717	RDTPHS=1./DTPHS
2718	CAPA=R_D/CP
2719	RG=1./G
2720	AVRAIN=AVRAIN+1.
2721	!
2722	!-----------------------------------------------------------------------
2723	!
2724	!*** PREPARE NEEDED ARRAYS
2725	!
2726	!-----------------------------------------------------------------------
2727	!$omp parallel do &
2728	!$omp& private(i,j)
2729	DO J=MYJS2,MYJE2
2730	DO I=MYIS1,MYIE1
2731	!
2732	PDSL(I,J)=PD(I,J)*RES(I,J)
2733	P8W(I,KTE+1,J)=PT
2734	LOWLYR(I,J)=KTS !<---- The lowest model layer counted from the bottom.
2735	XLAND(I,J)=SM(I,J)+1.
2736	!-----------------------------------------------------------------------
2737	!*** FILL RAINNC WITH ZERO (NORMALLY CONTAINS THE NONCONVECTIVE
2738	!*** ACCUMULATED RAIN BUT NOT YET USED BY NMM).
2739	!*** CAN BE OBTAINED FROM ACPREC AND CUPREC (ACPREC-CUPREC).
2740	!-----------------------------------------------------------------------
2741	RAINNC(I,J)=0.
2742	!
2743	ENDDO
2744	ENDDO
2745	!
2746	!-----------------------------------------------------------------------
2747	!*** FILL THE SINGLE-COLUMN INPUT
2748	!-----------------------------------------------------------------------
2749	!
2750	!$omp parallel do &
2751	!$omp& private(dpl,i,j,k,plyr,ql,tl)
2752	DO J=MYJS2,MYJE2
2753	DO K=KTS,KTE
2754	DO I=MYIS1,MYIE1
2755	DPL=DETA1(K)PDTOP+DETA2(K)PDSL(I,J)
2756	QL(K)=MAX(Q(I,J,K),EPSQ)
2757	!!! PLYR=AETA1(K)PDTOP+AETA2(K)PDSL(I,J)+PT
2758	PLYR=(PINT(I,J,K)+PINT(I,J,K+1))*0.5
2759	TL(K)=T(I,J,K)
2760	!
2761	RR(I,K,J)=PLYR/(R_DTL(K)(P608*QL(K)+1.))
2762	T_PHY(I,K,J)=TL(K)
2763	PI_PHY(I,K,J)=(PLYR1.E-5)*CAPA
2764	TH_PHY(I,K,J)=TL(K)/PI_PHY(I,K,J)
2765	!!! P8W(I,KFLIP,J)=PINT(I,J,K+1)
2766	P8W(I,K,J)=ETA1(K)PDTOP+ETA2(K)PDSL(I,J)+PT
2767	P_PHY(I,K,J)=PLYR
2768	DZ(I,K,J)=DPL*RG/RR(I,K,J)
2769	CWM_PHY(I,K,J)=CWM(I,J,K)
2770	ENDDO
2771	!
2772	ENDDO
2773	ENDDO
2774	!-----------------------------------------------------------------------
2775	!
2776	!*** CALL MICROPHYSICS
2777	!
2778	!-----------------------------------------------------------------------
2779	!
2780	CALL SET_TILES(GRID,IDS+1,IDE-1,JDS+2,JDE-2,ITS,ITE,JTS,JTE)
2781	!
2782	CALL MICROPHYSICS_DRIVER( &
2783	& TH=TH_PHY,RHO=RR,PI_PHY=PI_PHY,P=P_PHY &
2784	& ,RAINNC=RAINNC,RAINNCV=RAINNCV &
2785	& ,DZ8W=DZ,P8W=P8W,DT=DTPHS,DX=DX,DY=DY &
2786	& ,MP_PHYSICS=CONFIG_FLAGS%MP_PHYSICS &
2787	#ifdef WRF_CHEM
2788	& ,CHEM_OPT=CONFIG_FLAGS%CHEM_OPT &
2789	& ,PROGN=CONFIG_FLAGS%PROGN &
2790	#endif
2791	& ,SPECIFIED=CONFIG_FLAGS%SPECIFIED &
2792	& .OR.CONFIG_FLAGS%NESTED &
2793	& ,SPEC_ZONE=0,WARM_RAIN=WARM_RAIN &
2794	& ,XLAND=XLAND,ITIMESTEP=NTSD-1 &
2795	& ,F_ICE_PHY=F_ICE,F_RAIN_PHY=F_RAIN &
2796	& ,F_RIMEF_PHY=F_RIMEF &
2797	& ,LOWLYR=LOWLYR,SR=SR &
2798	& ,QV_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QV),F_QV=F_QV &
2799	& ,QC_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QC),F_QC=F_QC &
2800	& ,QR_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QR),F_QR=F_QR &
2801	& ,QI_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QI),F_QI=F_QI &
2802	& ,QS_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QS),F_QS=F_QS &
2803	& ,QG_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QG),F_QG=F_QG &
2804	& ,QNI_CURR=SCALAR_TRANS(IMS,KMS,JMS,P_QNI),F_QNI=F_QNI &
2805	& ,QNR_CURR=SCALAR_TRANS(IMS,KMS,JMS,P_QNR),F_QNR=F_QNR &
2806	& ,QT_CURR=CWM_PHY,F_QT=QT_PRESENT &
2807	& ,MP_RESTART_STATE=MP_RESTART_STATE &
2808	& ,TBPVS_STATE=TBPVS_STATE &
2809	& ,TBPVS0_STATE=TBPVS0_STATE &
2810	& ,IDS=IDS,IDE=IDE,JDS=JDS,JDE=JDE,KDS=KDS,KDE=KDE &
2811	& ,IMS=IMS,IME=IME,JMS=JMS,JME=JME,KMS=KMS,KME=KME &
2812	& ,I_START=GRID%I_START,I_END=GRID%I_END &
2813	& ,J_START=GRID%J_START,J_END=GRID%J_END &
2814	& ,KTS=KTS,KTE=KTE,NUM_TILES=GRID%NUM_TILES &
2815	& ,ID=grid%id &
2816	)
2817
2818	!$omp parallel do &
2819	!$omp& private(ij)
2820	DO IJ=1,GRID%NUM_TILES
2821	CALL MICROPHYSICS_ZERO_OUTA( &
2822	MOIST_TRANS,N_MOIST,CONFIG_FLAGS &
2823	,IDS,IDE,JDS,JDE,KDS,KDE &
2824	,IMS,IME,JMS,JME,KMS,KME &
2825	,GRID%I_START(IJ),GRID%I_END(IJ) &
2826	,GRID%J_START(IJ),GRID%J_END(IJ) &
2827	,KTS,KTE )
2828	ENDDO
2829
2830
2831
2832	!
2833	!-----------------------------------------------------------------------
2834	!
2835	E_BDY=(ITE>=IDE)
2836	!
2837	!-----------------------------------------------------------------------
2838	!*** UPDATE TEMPERATURE, SPECIFIC HUMIDITY, CLOUD WATER, AND HEATING.
2839	!-----------------------------------------------------------------------
2840	!$omp parallel do &
2841	!$omp& private(i,iendx,j,k,tnew)
2842	DO K=KTS,KTE
2843	DO J=MYJS2,MYJE2
2844	IENDX=MYIE1
2845	IF(E_BDY.AND.MOD(J,2)==0)IENDX=IENDX-1
2846	DO I=MYIS1,IENDX
2847	TNEW=TH_PHY(I,K,J)*PI_PHY(I,K,J)
2848	TRAIN(I,J,K)=TRAIN(I,J,K)+(TNEW-T(I,J,K))*RDTPHS
2849	T(I,J,K)=TNEW
2850	Q(I,J,K)=MOIST_TRANS(I,K,J,P_QV)/(1.+MOIST_TRANS(I,K,J,P_QV))
2851	CWM(I,J,K)=CWM_PHY(I,K,J)
2852	ENDDO
2853	ENDDO
2854	ENDDO
2855	!
2856	!-----------------------------------------------------------------------
2857	!*** UPDATE PRECIPITATION.
2858	!*** NOTE: RAINNC IS ACCUMULATED INSIDE MICROPHYSICS BUT NMM ZEROES IT
2859	!*** OUT ABOVE SINCE IT IS ONLY A LOCAL ARRAY FOR NOW.
2860	!-----------------------------------------------------------------------
2861	!
2862	!$omp parallel do &
2863	!$omp& private(i,iendx,j,pcpcol)
2864	DO J=MYJS2,MYJE2
2865	IENDX=MYIE1
2866	IF(E_BDY.AND.MOD(J,2)==0)IENDX=IENDX-1
2867	DO I=MYIS1,IENDX
2868	PCPCOL=RAINNCV(I,J)*1.E-3
2869	PREC(I,J)=PREC(I,J)+PCPCOL
2870	ACPREC(I,J)=ACPREC(I,J)+PCPCOL
2871	ENDDO
2872	ENDDO
2873	!
2874	!-----------------------------------------------------------------------
2875	!*** REFILL THE MOIST ARRAY.
2876	!-----------------------------------------------------------------------
2877	!
2878	DO N=1,N_MOIST
2879	!$omp parallel do &
2880	!$omp& private(i,j,k)
2881	DO J=JMS,JME
2882	DO K=KMS,KME
2883	DO I=IMS,IME
2884	MOIST(I,J,K,N)=MOIST_TRANS(I,K,J,N)
2885	ENDDO
2886	ENDDO
2887	ENDDO
2888	ENDDO
2889	!
2890	!-----------------------------------------------------------------------
2891	!
2892	IF(CONFIG_FLAGS%MP_PHYSICS/=ETAMPNEW.and.config_flags%mp_physics/=etamp_hwrf)THEN
2893	DO N=1,N_SCALAR
2894	!$omp parallel do &
2895	!$omp& private(i,j,k)
2896	DO J=JMS,JME
2897	DO K=KMS,KME
2898	DO I=IMS,IME
2899	SCALAR(I,J,K,N)=SCALAR_TRANS(I,K,J,N)
2900	ENDDO
2901	ENDDO
2902	ENDDO
2903	ENDDO
2904	ENDIF
2905	!
2906	!-----------------------------------------------------------------------
2907	!
2908	DEALLOCATE(MOIST_TRANS,STAT=ISTAT)
2909	DEALLOCATE(SCALAR_TRANS,STAT=ISTAT)
2910	!
2911	!-----------------------------------------------------------------------
2912	!
2913	END SUBROUTINE GSMDRIVE
2914	!
2915	!-----------------------------------------------------------------------
2916	!***********************************************************************
2917	SUBROUTINE UPDATE_MOIST(MOIST,Q,CWM,F_ICE,F_RAIN,N_MOIST &
2918	& ,IDS,IDE,JDS,JDE,KDS,KDE &
2919	& ,IMS,IME,JMS,JME,KMS,KME &
2920	& ,ITS,ITE,JTS,JTE,KTS,KTE)
2921	!***********************************************************************
2922	!-----------------------------------------------------------------------
2923	!
2924	IMPLICIT NONE
2925	!
2926	!-----------------------------------------------------------------------
2927	!
2928	INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
2929	& ,IMS,IME,JMS,JME,KMS,KME &
2930	& ,ITS,ITE,JTS,JTE,KTS,KTE &
2931	& ,N_MOIST
2932	!
2933	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: CWM,Q
2934	!
2935	REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: F_ICE & !<--- Used only with physics (IKJ)
2936	& ,F_RAIN
2937	!
2938	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME,N_MOIST),INTENT(OUT) :: MOIST
2939	!
2940	!-----------------------------------------------------------------------
2941	!*** LOCAL VARIABLES
2942	!-----------------------------------------------------------------------
2943	!
2944	INTEGER :: I,J,K
2945	!
2946	REAL :: FICE,FRAIN,QI,QR,QW,WC
2947	!
2948	!-----------------------------------------------------------------------
2949	!***********************************************************************
2950	!-----------------------------------------------------------------------
2951	!
2952	DO K=KTS,KTE
2953	DO J=MYJS,MYJE
2954	DO I=MYIS,MYIE
2955	MOIST(I,J,K,P_QV)=Q(I,J,K)/(1.-Q(I,J,K))
2956	WC=CWM(I,J,K)
2957	QI=0.
2958	QR=0.
2959	QW=0.
2960	FICE=F_ICE(I,K,J)
2961	FRAIN=F_RAIN(I,K,J)
2962	!
2963	IF(FICE>=1.)THEN
2964	QI=WC
2965	ELSEIF(FICE<=0.)THEN
2966	QW=WC
2967	ELSE
2968	QI=FICE*WC
2969	QW=WC-QI
2970	ENDIF
2971	!
2972	IF(QW>0..AND.FRAIN>0.)THEN
2973	IF(FRAIN>=1.)THEN
2974	QR=QW
2975	QW=0.
2976	ELSE
2977	QR=FRAIN*QW
2978	QW=QW-QR
2979	ENDIF
2980	ENDIF
2981	!
2982	MOIST(I,J,K,P_QC)=QW
2983	MOIST(I,J,K,P_QR)=QR
2984	MOIST(I,J,K,P_QI)=0.
2985	MOIST(I,J,K,P_QS)=QI
2986	MOIST(I,J,K,P_QG)=0.
2987	ENDDO
2988	ENDDO
2989	ENDDO
2990	!
2991	!-----------------------------------------------------------------------
2992	!
2993	END SUBROUTINE UPDATE_MOIST
2994	!
2995	!-----------------------------------------------------------------------
2996	!***********************************************************************
2997	!-----------------------------------------------------------------------
2998	!
2999	END MODULE MODULE_PHYSICS_CALLS
3000	!
3001	!-------------------------------------------------------------------

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format