Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

module_NEST_UTIL.F @ 1419

Last change on this file since 1419 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: 26.0 KB

Line
1	!
2	!NCEP_MESO:MODEL_LAYER: BOUNDARY CONDITION UPDATES
3	!
4	!----------------------------------------------------------------------
5	!
6	MODULE module_NEST_UTIL
7	!
8	!----------------------------------------------------------------------
9	USE MODULE_MPP
10	USE MODULE_STATE_DESCRIPTION
11	USE MODULE_DM
12	!
13	!#ifdef DM_PARALLEL
14	! INCLUDE "mpif.h"
15	!#endif
16	!----------------------------------------------------------------------
17	CONTAINS
18	!
19	!*********************************************************************************************
20	SUBROUTINE NESTBC_PATCH(PD_BXS,PD_BXE,PD_BYS,PD_BYE &
21	,T_BXS,T_BXE,T_BYS,T_BYE,Q_BXS,Q_BXE,Q_BYS,Q_BYE &
22	,U_BXS,U_BXE,U_BYS,U_BYE,V_BXS,V_BXE,V_BYS,V_BYE &
23	,Q2_BXS,Q2_BXE,Q2_BYS,Q2_BYE &
24	,CWM_BXS,CWM_BXE,CWM_BYS,CWM_BYE &
25	,PD_BTXS,PD_BTXE,PD_BTYS,PD_BTYE &
26	,T_BTXS,T_BTXE,T_BTYS,T_BTYE,Q_BTXS,Q_BTXE,Q_BTYS,Q_BTYE &
27	,U_BTXS,U_BTXE,U_BTYS,U_BTYE,V_BTXS,V_BTXE,V_BTYS,V_BTYE &
28	,Q2_BTXS,Q2_BTXE,Q2_BTYS,Q2_BTYE &
29	,CWM_BTXS,CWM_BTXE,CWM_BTYS,CWM_BTYE &
30	!
31	,PDTMP_B,TTMP_B, QTMP_B,UTMP_B,VTMP_B,Q2TMP_B,CWMTMP_B &
32	,PDTMP_BT,TTMP_BT,QTMP_BT,UTMP_BT,VTMP_BT,Q2TMP_BT,CWMTMP_BT &
33	!
34	,SPEC_BDY_WIDTH &
35	,IDS,IDE,JDS,JDE,KDS,KDE &
36	,IMS,IME,JMS,JME,KMS,KME &
37	,ITS,ITE,JTS,JTE,KTS,KTE )
38	!**********************************************************************
39	!$$$ SUBPROGRAM DOCUMENTATION BLOCK
40	! . . .
41	! SUBPROGRAM: PATCH
42	! PRGRMMR: gopal
43	!
44	! ABSTRACT:
45	! THIS IS JUST A FIX FOR USING NESTED BOUNDARIES IN THE HALO REGION
46	! PROGRAM HISTORY LOG:
47	! 09-23-2004 : gopal
48	!
49	! USAGE: CALL PATCH FROM SUBROUTINE SOLVE_RUNSTREAM FOR NESTED DOMAIN ONLY
50	!
51	! ATTRIBUTES:
52	! LANGUAGE: FORTRAN 90
53	! MACHINE : IBM SP
54	!$$$
55	!**********************************************************************
56	!----------------------------------------------------------------------
57	!
58	IMPLICIT NONE
59	!
60	!----------------------------------------------------------------------
61	!
62
63	INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
64	,IMS,IME,JMS,JME,KMS,KME &
65	,ITS,ITE,JTS,JTE,KTS,KTE
66	INTEGER,INTENT(IN) :: SPEC_BDY_WIDTH
67	!
68	!
69	REAL,DIMENSION(IMS:IME,1,SPEC_BDY_WIDTH) &
70	,INTENT(INOUT) :: PD_BYS,PD_BYE &
71	,PD_BTYS,PD_BTYE
72
73	REAL,DIMENSION(IMS:IME,KMS:KME,SPEC_BDY_WIDTH) &
74	,INTENT(INOUT) :: CWM_BYS,CWM_BYE &
75	,Q_BYS,Q_BYE &
76	,Q2_BYS,Q2_BYE &
77	,T_BYS,T_BYE &
78	,U_BYS,U_BYE &
79	,V_BYS,V_BYE
80
81	REAL,DIMENSION(IMS:IME,KMS:KME,SPEC_BDY_WIDTH) &
82	,INTENT(INOUT) :: CWM_BTYS,CWM_BTYE &
83	,Q_BTYS,Q_BTYE &
84	,Q2_BTYS,Q2_BTYE &
85	,T_BTYS,T_BTYE &
86	,U_BTYS,U_BTYE &
87	,V_BTYS,V_BTYE
88
89	!
90
91	REAL,DIMENSION(JMS:JME,1,SPEC_BDY_WIDTH) &
92	,INTENT(INOUT) :: PD_BXS,PD_BXE &
93	,PD_BTXS,PD_BTXE
94
95	REAL,DIMENSION(JMS:JME,KMS:KME,SPEC_BDY_WIDTH) &
96	,INTENT(INOUT) :: CWM_BXS,CWM_BXE &
97	,Q_BXS,Q_BXE &
98	,Q2_BXS,Q2_BXE &
99	,T_BXS,T_BXE &
100	,U_BXS,U_BXE &
101	,V_BXS,V_BXE
102
103	REAL,DIMENSION(JMS:JME,KMS:KME,SPEC_BDY_WIDTH) &
104	,INTENT(INOUT) :: CWM_BTXS,CWM_BTXE &
105	,Q_BTXS,Q_BTXE &
106	,Q2_BTXS,Q2_BTXE &
107	,T_BTXS,T_BTXE &
108	,U_BTXS,U_BTXE &
109	,V_BTXS,V_BTXE
110
111	!
112
113	REAL,DIMENSION(IMS:IME,JMS:JME) &
114	,INTENT(IN) :: PDTMP_B,PDTMP_BT
115
116	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME) &
117	,INTENT(IN) :: CWMTMP_B,CWMTMP_BT &
118	,QTMP_B,QTMP_BT &
119	,Q2TMP_B,Q2TMP_BT &
120	,TTMP_B,TTMP_BT &
121	,UTMP_B,UTMP_BT &
122	,VTMP_B,VTMP_BT
123
124	!
125
126	!----------------------------------------------------------------------
127	!
128	!*** LOCAL VARIABLES
129	!
130	LOGICAL :: E_BDY,W_BDY,N_BDY,S_BDY
131	INTEGER :: I,J,K,IBDY,II,JJ,IB,JB,IIM,JJM,BF
132	!----------------------------------------------------------------------
133	!**********************************************************************
134	!----------------------------------------------------------------------
135	!
136	W_BDY=(ITS==IDS)
137	E_BDY=(ITE==IDE)
138	S_BDY=(JTS==JDS)
139	N_BDY=(JTE==JDE)
140
141	!----------------------------------------------------------------------
142	!*** WEST AND EAST BOUNDARIES
143	!----------------------------------------------------------------------
144	!
145	!*** USE IBDY=1 FOR WEST; 2 FOR EAST.
146
147	! WRITE(0,*)'WESTERN BC FOR PATCH',IDS,MAX(JTS-1,JDS+3-1),MIN(JTE+1,JDE-2)
148	!
149
150	DO IBDY=1,2
151	!
152	!*** MAKE SURE THE PROCESSOR HAS THIS BOUNDARY.
153	!
154	IF(W_BDY.AND.IBDY.EQ.1)THEN
155	! BF=P_XSB ! Which boundary (XSB=the boundary where X is at its start)
156	IB=1 ! Which cell in from boundary
157	II=1 ! Which cell in the domain
158
159	DO J=MAX(JTS-1,JDS+3-1),MIN(JTE+1,JDE-2)
160	IF(MOD(J,2).EQ.1)THEN ! J=3,5,7,9
161	PD_BXS(J,1,IB) =PDTMP_B(II,J)
162	PD_BTXS(J,1,IB) =PDTMP_BT(II,J)
163	ENDIF
164	ENDDO
165	!
166	DO K=KTS,KTE
167	DO J=MAX(JTS-1,JDS+3-1),MIN(JTE+1,JDE-2)
168	IF(MOD(J,2).EQ.1)THEN ! J=3,5,7,9
169	T_BXS(J,K,IB) = TTMP_B(II,J,K)
170	T_BTXS(J,K,IB) = TTMP_BT(II,J,K)
171	Q_BXS(J,K,IB) = QTMP_B(II,J,K)
172	Q_BTXS(J,K,IB) = QTMP_BT(II,J,K)
173	Q2_BXS(J,K,IB) = Q2TMP_B(II,J,K)
174	Q2_BTXS(J,K,IB) = Q2TMP_BT(II,J,K)
175	CWM_BXS(J,K,IB) = CWMTMP_B(II,J,K)
176	CWM_BTXS(J,K,IB) = CWMTMP_BT(II,J,K)
177	ENDIF
178	ENDDO
179	ENDDO
180
181	DO K=KTS,KTE
182	DO J=MAX(JTS-1,JDS+2-1),MIN(JTE+1,JDE-1)
183	IF(MOD(J,2).EQ.0)THEN ! J=2,4,6,8
184	U_BXS(J,K,IB) = UTMP_B(II,J,K)
185	U_BTXS(J,K,IB) = UTMP_BT(II,J,K)
186	V_BXS(J,K,IB) = VTMP_B(II,J,K)
187	V_BTXS(J,K,IB) = VTMP_BT(II,J,K)
188	ENDIF
189	ENDDO
190	ENDDO
191
192	ELSEIF (E_BDY.AND.IBDY.EQ.2) THEN
193
194	! BF=P_XEB ! Which boundary (XEB=the boundary where X is at its end)
195	IB=1 ! Which cell in from boundary
196	II=IDE ! Which cell in the domain
197
198	DO J=MAX(JTS-1,JDS+3-1),MIN(JTE+1,JDE-2)
199	IF(MOD(J,2).EQ.1)THEN ! J=3,5,7,9
200	PD_BXE(J,1,IB) =PDTMP_B(II,J)
201	PD_BTXE(J,1,IB) =PDTMP_BT(II,J)
202	ENDIF
203	ENDDO
204	!
205	DO K=KTS,KTE
206	DO J=MAX(JTS-1,JDS+3-1),MIN(JTE+1,JDE-2)
207	IF(MOD(J,2).EQ.1)THEN ! J=3,5,7,9
208	T_BXE(J,K,IB) = TTMP_B(II,J,K)
209	T_BTXE(J,K,IB) = TTMP_BT(II,J,K)
210	Q_BXE(J,K,IB) = QTMP_B(II,J,K)
211	Q_BTXE(J,K,IB) = QTMP_BT(II,J,K)
212	Q2_BXE(J,K,IB) = Q2TMP_B(II,J,K)
213	Q2_BTXE(J,K,IB) = Q2TMP_BT(II,J,K)
214	CWM_BXE(J,K,IB) = CWMTMP_B(II,J,K)
215	CWM_BTXE(J,K,IB) = CWMTMP_BT(II,J,K)
216	ENDIF
217	ENDDO
218	ENDDO
219
220	DO K=KTS,KTE
221	DO J=MAX(JTS-1,JDS+2-1),MIN(JTE+1,JDE-1)
222	IF(MOD(J,2).EQ.0)THEN ! J=2,4,6,8
223	U_BXE(J,K,IB) = UTMP_B(II,J,K)
224	U_BTXE(J,K,IB) = UTMP_BT(II,J,K)
225	V_BXE(J,K,IB) = VTMP_B(II,J,K)
226	V_BTXE(J,K,IB) = VTMP_BT(II,J,K)
227	ENDIF
228	ENDDO
229	ENDDO
230
231	ENDIF
232	ENDDO
233	!
234	!----------------------------------------------------------------------
235	!*** SOUTH AND NORTH BOUNDARIES
236	!----------------------------------------------------------------------
237	!
238	!*** USE IBDY=1 FOR SOUTH; 2 FOR NORTH
239	!
240	DO IBDY=1,2
241	!
242	!*** MAKE SURE THE PROCESSOR HAS THIS BOUNDARY.
243	!
244	IF(S_BDY.AND.IBDY.EQ.1) THEN
245	!
246	! BF=P_YSB ! Which boundary (YSB=the boundary where Y is at its start)
247	JB=1 ! Which cell in from boundary
248	JJ=1 ! Which cell in the domain
249	!
250	DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
251	PD_BYS(I,1,JB) = PDTMP_B(I,JJ)
252	PD_BTYS(I,1,JB)= PDTMP_BT(I,JJ)
253	ENDDO
254
255	!
256	DO K=KTS,KTE
257	DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
258	T_BYS(I,K,JB) = TTMP_B(I,JJ,K)
259	T_BTYS(I,K,JB) = TTMP_BT(I,JJ,K)
260	Q_BYS(I,K,JB) = QTMP_B(I,JJ,K)
261	Q_BTYS(I,K,JB) = QTMP_BT(I,JJ,K)
262	Q2_BYS(I,K,JB) = Q2TMP_B(I,JJ,K)
263	Q2_BTYS(I,K,JB) = Q2TMP_BT(I,JJ,K)
264	CWM_BYS(I,K,JB) = CWMTMP_B(I,JJ,K)
265	CWM_BTYS(I,K,JB)= CWMTMP_BT(I,JJ,K)
266	ENDDO
267	ENDDO
268
269	DO K=KTS,KTE
270	DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
271	U_BYS(I,K,JB) = UTMP_B(I,JJ,K)
272	U_BTYS(I,K,JB) = UTMP_BT(I,JJ,K)
273	V_BYS(I,K,JB) = VTMP_B(I,JJ,K)
274	V_BTYS(I,K,JB) = VTMP_BT(I,JJ,K)
275	ENDDO
276	ENDDO
277
278	ELSEIF (N_BDY.AND.IBDY.EQ.2) THEN
279	! BF=P_YEB ! Which boundary (YEB=the boundary where Y is at its end)
280	JB=1 ! Which cell in from boundary
281	JJ=JDE ! Which cell in the domain
282
283	DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
284	PD_BYE(I,1,JB) = PDTMP_B(I,JJ)
285	PD_BTYE(I,1,JB)= PDTMP_BT(I,JJ)
286	ENDDO
287
288	!
289	DO K=KTS,KTE
290	DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
291	T_BYE(I,K,JB) = TTMP_B(I,JJ,K)
292	T_BTYE(I,K,JB) = TTMP_BT(I,JJ,K)
293	Q_BYE(I,K,JB) = QTMP_B(I,JJ,K)
294	Q_BTYE(I,K,JB) = QTMP_BT(I,JJ,K)
295	Q2_BYE(I,K,JB) = Q2TMP_B(I,JJ,K)
296	Q2_BTYE(I,K,JB) = Q2TMP_BT(I,JJ,K)
297	CWM_BYE(I,K,JB) = CWMTMP_B(I,JJ,K)
298	CWM_BTYE(I,K,JB)= CWMTMP_BT(I,JJ,K)
299	ENDDO
300	ENDDO
301
302	DO K=KTS,KTE
303	DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
304	U_BYE(I,K,JB) = UTMP_B(I,JJ,K)
305	U_BTYE(I,K,JB) = UTMP_BT(I,JJ,K)
306	V_BYE(I,K,JB) = VTMP_B(I,JJ,K)
307	V_BTYE(I,K,JB) = VTMP_BT(I,JJ,K)
308	ENDDO
309	ENDDO
310
311
312
313	ENDIF
314	ENDDO
315	END SUBROUTINE NESTBC_PATCH
316
317	!----------------------------------------------------------------------
318	!
319	SUBROUTINE STATS_FOR_MOVE (XLOC,YLOC,PDYN,MSLP,SQWS &
320	,PINT,T,Q,U,V &
321	,FIS,PD,SM,PDTOP,PTOP &
322	,DETA1,DETA2 &
323	#ifdef HWRF
324	,RESTART,NTIME0 & ! zhang's doing
325	,MOVED,MVNEST,NTSD,NPHS,CFREQ & ! CFREQDTNPHS=540s
326	#else
327	,MOVED,MVNEST,NTSD,NPHS &
328	#endif
329	,IDS,IDE,JDS,JDE,KDS,KDE &
330	,IMS,IME,JMS,JME,KMS,KME &
331	,ITS,ITE,JTS,JTE,KTS,KTE )
332
333	!**********************************************************************
334	!$$$ SUBPROGRAM DOCUMENTATION BLOCK
335	! . . .
336	! SUBPROGRAM: STATS_FOR_MOVE
337	! PRGRMMR: gopal
338	!
339	! ABSTRACT:
340	! THIS ROUTINE COMPUTES SOME STATS REQUIRED FOR AUTOMATIC GRID MOTION
341	! PROGRAM HISTORY LOG:
342	! 05-18-2005 : gopal
343	!
344	! USAGE: CALL STATS_FOR_MOVE FROM SUBROUTINE SOLVE_RUNSTREAM FOR NESTED DOMAIN ONLY
345	!
346	! ATTRIBUTES:
347	! LANGUAGE: FORTRAN 90
348	! MACHINE : IBM SP
349	!$$$
350	!**********************************************************************
351
352	USE MODULE_MODEL_CONSTANTS
353	USE MODULE_DM
354
355	IMPLICIT NONE
356	!
357	LOGICAL,EXTERNAL :: wrf_dm_on_monitor
358	LOGICAL,INTENT(INOUT) :: MVNEST ! NMM SWITCH FOR GRID MOTION
359	LOGICAL,INTENT(IN) :: MOVED
360	INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
361	,IMS,IME,JMS,JME,KMS,KME &
362	,ITS,ITE,JTS,JTE,KTS,KTE &
363	#ifdef HWRF
364	,NTSD,NPHS,CFREQ
365	#else
366	,NTSD,NPHS
367	#endif
368	!
369	INTEGER, INTENT(OUT) :: XLOC,YLOC
370	#ifdef HWRFX
371	INTEGER :: NXLOC,NYLOC
372	REAL :: NSUM1,NSUM2,NSUM3
373	#endif
374	REAL, DIMENSION(KMS:KME), INTENT(IN) :: DETA1,DETA2
375	REAL, INTENT(IN) :: PDTOP,PTOP
376	REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(IN) :: FIS,PD,SM
377	REAL, DIMENSION(IMS:IME,JMS:JME,KMS:KME), INTENT(IN) :: PINT,T,Q,U,V
378	REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(OUT) :: PDYN,MSLP,SQWS
379	!
380	! LOCAL
381
382	#ifdef HWRF
383	!zhang's doing
384	#ifdef HWRFX
385	INTEGER,INTENT(INOUT) :: NTIME0
386	#else
387	INTEGER :: NTIME0
388	#endif
389	LOGICAL,INTENT(IN) :: RESTART
390	#else
391	INTEGER,SAVE :: NTIME0
392	#endif
393	INTEGER :: IM,JM,IP,JP
394	INTEGER :: I,K,J,XR,YR,DTMOVE,IDUM,JDUM,ITF,JTF
395	REAL, PARAMETER :: LAPSR=6.5E-3, GI=1./G,D608=0.608
396	REAL, PARAMETER :: COEF3=287.05GILAPSR, COEF2=-1./COEF3
397	REAL, PARAMETER :: TRG=2.0R_DGI,LAPSI=1.0/LAPSR
398	REAL :: DZ,RTOPP,APELP,A,TSFC,STMP0,STMP1
399	REAL :: SMSUM,SMOUT,XDIFF,YDIFF,PCUT,PGR
400	REAL :: MINGBL_PDYN,MAXGBL_PDYN,MAXGBL_SQWS
401	REAL :: MINGBL_MIJ
402	REAL, DIMENSION(IMS:IME,JMS:JME) :: MIJ
403	REAL, DIMENSION(IMS:IME,JMS:JME,KMS:KME) :: Z
404
405	! EXEC
406
407	ITF=MIN(ITE,IDE-1)
408	JTF=MIN(JTE,JDE-1)
409
410	!----------------------------------------------------------------------------------
411
412	! KEEP NEST MOTION IN SINK WITH PHYSICS TIME STEPS
413	#ifdef HWRF
414	IF(MOD(NTSD+1,CFREQ*NPHS)/=0)THEN !FOR FULL COUPLING
415	IF(MOVED) NTIME0=NTSD !FOR UPDATING NTIM0
416	#else
417	IF(MOD(NTSD+1,NPHS)/=0)THEN
418	#endif
419	MVNEST=.FALSE.
420	RETURN
421	ENDIF
422
423	! DETERMINE THE HEIGHTS ON THE PARENT DOMAIN
424
425	DO J = JTS, MIN(JTE,JDE)
426	DO I = ITS, MIN(ITE,IDE)
427	Z(I,J,1)=FIS(I,J)*GI
428	ENDDO
429	ENDDO
430	!
431	DO K = KTS,KTE
432	DO J = JTS, MIN(JTE,JDE)
433	DO I = ITS, MIN(ITE,IDE)
434	APELP = (PINT(I,J,K+1)+PINT(I,J,K))
435	RTOPP = TRGT(I,J,K)(1.0+Q(I,J,K)*P608)/APELP
436	DZ = RTOPP(DETA1(K)PDTOP+DETA2(K)*PD(I,J))
437	Z(I,J,K+1) = Z(I,J,K) + DZ
438	ENDDO
439	ENDDO
440	ENDDO
441
442	! DETERMINE THE MEAN SEA LEVEL PRESSURE, THE VERTICALLY AVERAGED WIND
443	! SPEED AT ABOUT LEVELS 9 10 AND 11 AND THE DYNAMIC PRESSURES DEFINED
444	! FROM BASIC BERNOULLI's THEOREM
445
446	DO J = JTS, MIN(JTE,JDE)
447	DO I = ITS, MIN(ITE,IDE)
448	TSFC = T(I,J,1)(1.+D608Q(I,J,1)) + LAPSR(Z(I,J,1)+Z(I,J,2))0.5
449	A = LAPSR*Z(I,J,1)/TSFC
450	MSLP(I,J) = PINT(I,J,1)(1-A)*COEF2
451	SQWS(I,J) = (U(I,J,9)U(I,J,9) + V(I,J,9)V(I,J,9) &
452	+ U(I,J,10)U(I,J,10) + V(I,J,10)V(I,J,10) &
453	+ U(I,J,11)U(I,J,11) + V(I,J,11)V(I,J,11))/3.0
454	#ifdef HWRF
455	PDYN(I,J) = MSLP(I,J)
456	#else
457	PDYN(I,J) = MSLP(I,J) + 1.1*SQWS(I,J)/2.0
458	#endif
459	ENDDO
460	ENDDO
461
462	! FILTER OUT PDYN AND STORE THAT IN MIJ. THE MAXIMUM VALUE OF MIJ GIVES THE STORM CENTER
463	! ALSO DO THAT WITHIN A SUB DOMAIN
464
465	MAXGBL_PDYN=MAXVAL(PDYN(ITS:ITF,JTS:JTF))
466	CALL WRF_DM_MAXVAL(MAXGBL_PDYN,IDUM,JDUM)
467	MINGBL_PDYN=MINVAL(PDYN(ITS:ITF,JTS:JTF))
468	CALL WRF_DM_MINVAL(MINGBL_PDYN,IDUM,JDUM)
469	PCUT = 0.5*(MAXGBL_PDYN + MINGBL_PDYN)
470	!
471	IM=IDE/2 - IDE/6
472	IP=IDE/2 + IDE/6
473	JM=JDE/2 - JDE/4
474	JP=JDE/2 + JDE/4
475	!
476	DO J = JTS, MIN(JTE,JDE)
477	DO I = ITS, MIN(ITE,IDE)
478	IF(I .GE. IM .AND. I .LE. IP .AND. J .GE. JM .AND. J .LE. JP &
479	.AND. PCUT .GT. PDYN(I,J))THEN
480	MIJ(I,J) = PDYN(I,J)
481	ELSE
482	MIJ(I,J) = 105000.0
483	ENDIF
484	ENDDO
485	ENDDO
486
487	DO J = JTS, MIN(JTE,JDE)
488	DO I = ITS, MIN(ITE,IDE)
489	PDYN(I,J)=MIJ(I,J)
490	ENDDO
491	ENDDO
492
493	! DETERMINE THE LOCATION OF CENTER OF THE CIRCULATION DEFINED BY MIJ AND FIND THE CORRESPONDING MSLP
494
495	STMP0=MAXGBL_PDYN*100. ! define arbitrary maximum
496	MINGBL_MIJ=MINVAL(MIJ(ITS:ITF,JTS:JTF))
497	DO J = JTS, MIN(JTE,JDE)
498	DO I = ITS, MIN(ITE,IDE)
499	IF(MIJ(I,J) .EQ. MINGBL_MIJ)THEN
500	XLOC=I
501	YLOC=J
502	STMP0=MSLP(I,J)
503	ENDIF
504	ENDDO
505	ENDDO
506
507	CALL WRF_DM_MINVAL(MINGBL_MIJ,XLOC,YLOC)
508	CALL WRF_DM_MINVAL(STMP0,IDUM,JDUM)
509	#ifdef HWRFX
510	! USE CENTROID TO FIND THE CENTER Xuejin's doing
511
512	NSUM1=0.0
513	NSUM2=0.0
514	NSUM3=0.0
515	DO J = JTS, MIN(JTE,JDE)
516	DO I = ITS, MIN(ITE,IDE)
517	IF(I .GE. IM .AND. I .LE. IP .AND. J .GE. JM .AND. J .LE. JP )THEN
518	! IF(I .EQ. IM .AND. J .EQ. JM)THEN
519	NSUM1 = NSUM1 + I*(105000.1 - PDYN(I,J))
520	NSUM2 = NSUM2 + J*(105000.1 - PDYN(I,J))
521	NSUM3 = NSUM3 + (105000.1 - PDYN(I,J))
522	! NSUM1 = NSUM1 + I*(PCUT+0.1 - PDYN(I,J))
523	! NSUM2 = NSUM2 + J*(PCUT+0.1 - PDYN(I,J))
524	! NSUM3 = NSUM3 + (PCUT+0.1 - PDYN(I,J))
525	! WRITE(0,)'TEST',NSUM1,I,J,0.01(105000.0 - PDYN(I,J)),PDYN(I,J)
526	ENDIF
527	ENDDO
528	ENDDO
529	NSUM1 = WRF_DM_SUM_REAL(NSUM1)
530	NSUM2 = WRF_DM_SUM_REAL(NSUM2)
531	NSUM3 = WRF_DM_SUM_REAL(NSUM3)
532	NXLOC = NINT(NSUM1/NSUM3)
533	NYLOC = NINT(NSUM2/NSUM3)
534
535	WRITE(0,*)'NEW CALC',NSUM1,NSUM2,NSUM3
536	WRITE(0,*)'XLOC,YLOC',NXLOC,XLOC,NYLOC,YLOC
537
538	XLOC = NXLOC
539	YLOC = NYLOC
540
541	#endif
542
543	! DETERMINE THE MAXIMUM MSLP AT ABOUT 18 GRID POINTS AWAY FROM THE STORM CENTER
544
545	STMP1=0.0
546	DO J = JTS, MIN(JTE,JDE)
547	DO I = ITS, MIN(ITE,IDE)
548	IF(I .EQ. XLOC+18)THEN
549	XR=I
550	YR=J
551	STMP1=MSLP(I,J)
552	ENDIF
553	ENDDO
554	ENDDO
555
556	CALL WRF_DM_MAXVAL(STMP1,XR,YR)
557
558	!
559	! DETERMINE IF THE ENTIRE NESTED DOMAIN IS OVER LAND (SM=0)
560	!
561
562	SMSUM = 0.0
563	DO J = JTS, MIN(JTE,JDE)
564	DO I = ITS, MIN(ITE,IDE)
565	SMSUM = SMSUM + SM(I,J)
566	ENDDO
567	ENDDO
568
569	SMOUT=WRF_DM_SUM_REAL(SMSUM)/(IDE*JDE)
570
571	! STOP GRID MOTION. AVOID MOVING TOO RAPID GRID MOTION, SAY SOMETHING LIKE EVERY
572	! OTHER TIME STEP OR SO
573
574	PGR=STMP1-STMP0
575	XDIFF=ABS(XLOC - IDE/2)
576	YDIFF=ABS(YLOC - JDE/2)
577	#ifdef HWRF
578	!zhang's doing
579	IF((.NOT.RESTART .AND. NTSD==0) .OR. MOVED)NTIME0=NTSD
580	#else
581	IF(NTSD==0 .OR. MOVED)NTIME0=NTSD
582	#endif
583	DTMOVE=NTSD-NTIME0 ! TIME INTERVAL SINCE THE PREVIOUS MOVE
584	!
585	#ifdef HWRFX
586	IF(XDIFF .GE. 1 .OR. YDIFF .GE. 2) THEN
587	MVNEST=.TRUE.
588	NTIME0=NTSD
589	ELSE
590	MVNEST=.FALSE.
591	WRITE(0,*)'SUSPEND MOTION: DTMOVE=',DTMOVE,'LESS THAN 3 MINUTS'
592	WRITE(0,*)'SUSPEND MOTION: NTIME0=',NTIME0
593	ENDIF
594	#else
595	IF(DTMOVE .LE. 45 .OR. PGR .LE. 200.)THEN
596	WRITE(0,*)'SUSPEND MOTION: SMALL DTMOVE OR WEAK PGF:','DTMOVE=',DTMOVE,'PGR=',PGR
597	MVNEST=.FALSE. ! SET STATIC GRID
598	ELSE IF(STMP0 .GE. STMP1)THEN
599	WRITE(0,*)'SUSPEND MOTION: THERE IS NO VORTEX IN THE DOMAIN:','STMP0=',STMP0,'STMP1=',STMP1
600	MVNEST=.FALSE.
601	ELSE IF(XDIFF .GT. 24 .OR. YDIFF .GT. 24)THEN
602	WRITE(0,*)'SUSPEND MOTION: LOST VORTEX ','DTMOVE=',DTMOVE,'XDIFF=',XDIFF,'YDIFF=',YDIFF
603	MVNEST=.FALSE.
604	ELSE IF(SMOUT .LE. 0.2 .AND. XDIFF .GT. 12 .AND. YDIFF .GT. 12)THEN
605	WRITE(0,*)'SUSPEND MOTION: VORTEX LOST OVER LAND ','DTMOVE=',DTMOVE,'XDIFF=',XDIFF,'YDIFF=',YDIFF
606	MVNEST=.FALSE.
607	ELSE IF(SMOUT .LE. 0.2 .AND. PGR .LE. 400.)THEN
608	WRITE(0,*)'SUSPEND MOTION: VORTEX WEAK OVER LAND ','SMOUT=',SMOUT,'PGR=',PGR
609	MVNEST=.FALSE.
610	ELSE IF(SMOUT .LE. 0.2 .AND. DTMOVE .GE. 1500)THEN
611	WRITE(0,*)'SUSPEND MOTION: STOP MOTION OVER LAND','SMOUT=',SMOUT,'DTMOVE=',DTMOVE
612	MVNEST=.FALSE.
613	ELSE
614	MVNEST=.TRUE.
615	ENDIF
616	#endif
617
618	RETURN
619
620	END SUBROUTINE STATS_FOR_MOVE
621	!----------------------------------------------------------------------------------
622	SUBROUTINE MSLP_DIAG (MSLP,PINT,T,Q &
623	,FIS,PD,DETA1,DETA2,PDTOP &
624	,IDS,IDE,JDS,JDE,KDS,KDE &
625	,IMS,IME,JMS,JME,KMS,KME &
626	,ITS,ITE,JTS,JTE,KTS,KTE )
627
628
629	!**********************************************************************
630	!$$$ SUBPROGRAM DOCUMENTATION BLOCK
631	! . . .
632	! SUBPROGRAM: MSLP_DIAG
633	! PRGRMMR: gopal
634	!
635	! ABSTRACT:
636	! THIS ROUTINE COMPUTES MSLP OVER THE PARENT DOMAIN FOR DIAGONOSTIC PURPOSE
637	! PROGRAM HISTORY LOG:
638	! 07-21-2005 : gopal
639	!
640	! USAGE: CALL MSLP_DIAG FROM THE SOLVER
641	!
642	! ATTRIBUTES:
643	! LANGUAGE: FORTRAN 90
644	! MACHINE : IBM SP/Linux cluster
645	!$$$
646
647	USE MODULE_MODEL_CONSTANTS
648	USE MODULE_DM
649
650	IMPLICIT NONE
651
652	! global variables
653
654	INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
655	,IMS,IME,JMS,JME,KMS,KME &
656	,ITS,ITE,JTS,JTE,KTS,KTE
657
658	REAL, INTENT(IN) :: PDTOP
659	REAL, DIMENSION(KMS:KME), INTENT(IN) :: DETA1,DETA2
660	REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(INOUT) :: MSLP
661	REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(IN) :: FIS,PD
662	REAL, DIMENSION(IMS:IME,JMS:JME,KMS:KME), INTENT(IN) :: PINT,T,Q
663
664	! local variables
665
666	REAL, PARAMETER :: LAPSR=6.5E-3, GI=1./G,D608=0.608
667	REAL, PARAMETER :: COEF3=287.05GILAPSR, COEF2=-1./COEF3
668	REAL, PARAMETER :: TRG=2.0R_DGI,LAPSI=1.0/LAPSR
669	REAL :: RTOPP,APELP,DZ,SFCT,A
670	REAL, DIMENSION(IMS:IME,JMS:JME,KMS:KME) :: Z
671	INTEGER :: I,J,K
672	!-----------------------------------------------------------------------------------------------------
673
674
675	DO J = JTS, MIN(JTE,JDE)
676	DO I = ITS, MIN(ITE,IDE)
677	Z(I,J,1)=FIS(I,J)*GI
678	ENDDO
679	ENDDO
680
681	DO K = KTS,KTE
682	DO J = JTS, MIN(JTE,JDE)
683	DO I = ITS, MIN(ITE,IDE)
684	APELP = (PINT(I,J,K+1)+PINT(I,J,K))
685	RTOPP = TRGT(I,J,K)(1.0+Q(I,J,K)*P608)/APELP
686	DZ = RTOPP(DETA1(K)PDTOP+DETA2(K)*PD(I,J))
687	Z(I,J,K+1) = Z(I,J,K) + DZ
688	ENDDO
689	ENDDO
690	ENDDO
691
692	MSLP=-9999.99
693	DO J = JTS, MIN(JTE,JDE)
694	DO I = ITS, MIN(ITE,IDE)
695	SFCT = T(I,J,1)(1.+D608Q(I,J,1)) + LAPSR(Z(I,J,1)+Z(I,J,2))0.5
696	A = LAPSR*Z(I,J,1)/SFCT
697	MSLP(I,J) = PINT(I,J,1)(1-A)*COEF2
698	ENDDO
699	ENDDO
700
701
702	END SUBROUTINE MSLP_DIAG
703	!------------------------------------------------------------------------------------------------------
704
705	END MODULE module_NEST_UTIL

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

Download in other formats:

Original Format