module_NEST_UTIL.F
References to this file elsewhere.
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_B,T_B,Q_B,U_B,V_B,Q2_B,CWM_B &
21 ,PD_BT,T_BT,Q_BT,U_BT,V_BT,Q2_BT,CWM_BT &
22 ,PDTMP_B,TTMP_B,QTMP_B,UTMP_B,VTMP_B,Q2TMP_B,CWMTMP_B &
23 ,PDTMP_BT,TTMP_BT,QTMP_BT,UTMP_BT,VTMP_BT,Q2TMP_BT,CWMTMP_BT &
24 ,IJDS,IJDE,SPEC_BDY_WIDTH & ! min/max(id,jd)
25 ,IDS,IDE,JDS,JDE,KDS,KDE &
26 ,IMS,IME,JMS,JME,KMS,KME &
27 ,ITS,ITE,JTS,JTE,KTS,KTE )
28 !**********************************************************************
29 !$$$ SUBPROGRAM DOCUMENTATION BLOCK
30 ! . . .
31 ! SUBPROGRAM: PATCH
32 ! PRGRMMR: gopal
33 !
34 ! ABSTRACT:
35 ! THIS IS JUST A FIX FOR USING NESTED BOUNDARIES IN THE HALLO REGION
36 ! PROGRAM HISTORY LOG:
37 ! 09-23-2004 : gopal
38 !
39 ! USAGE: CALL PATCH FROM SUBROUTINE SOLVE_RUNSTREAM FOR NESTED DOMAIN ONLY
40 !
41 ! ATTRIBUTES:
42 ! LANGUAGE: FORTRAN 90
43 ! MACHINE : IBM SP
44 !$$$
45 !**********************************************************************
46 !----------------------------------------------------------------------
47 !
48 IMPLICIT NONE
49 !
50 !----------------------------------------------------------------------
51 !
52
53 INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
54 ,IMS,IME,JMS,JME,KMS,KME &
55 ,ITS,ITE,JTS,JTE,KTS,KTE
56 INTEGER,INTENT(IN) :: IJDS,IJDE,SPEC_BDY_WIDTH
57 !
58 !
59 REAL,DIMENSION(IJDS:IJDE,1,SPEC_BDY_WIDTH,4) &
60 ,INTENT(INOUT) :: PD_B,PD_BT
61 !
62 REAL,DIMENSION(IJDS:IJDE,KMS:KME,SPEC_BDY_WIDTH,4) &
63 ,INTENT(INOUT) :: CWM_B,Q_B,Q2_B, &
64 T_B,U_B,V_B
65 REAL,DIMENSION(IJDS:IJDE,KMS:KME,SPEC_BDY_WIDTH,4) &
66 ,INTENT(INOUT) :: CWM_BT,Q_BT,Q2_BT, &
67 T_BT,U_BT,V_BT
68
69 REAL,DIMENSION(IMS:IME,JMS:JME), INTENT(IN) :: PDTMP_B,PDTMP_BT
70
71 REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME), &
72 INTENT(IN) :: TTMP_B,QTMP_B,UTMP_B, &
73 VTMP_B,Q2TMP_B,CWMTMP_B
74
75 REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME), &
76 INTENT(IN) :: TTMP_BT,QTMP_BT,UTMP_BT, &
77 VTMP_BT,Q2TMP_BT,CWMTMP_BT
78 !
79 !----------------------------------------------------------------------
80 !
81 !*** LOCAL VARIABLES
82 !
83 LOGICAL :: E_BDY,W_BDY,N_BDY,S_BDY
84 INTEGER :: I,J,K,IBDY,II,JJ,IB,JB,IIM,JJM,BF
85 !----------------------------------------------------------------------
86 !**********************************************************************
87 !----------------------------------------------------------------------
88 !
89 W_BDY=(ITS==IDS)
90 E_BDY=(ITE==IDE)
91 S_BDY=(JTS==JDS)
92 N_BDY=(JTE==JDE)
93
94 !----------------------------------------------------------------------
95 !*** WEST AND EAST BOUNDARIES
96 !----------------------------------------------------------------------
97 !
98 !*** USE IBDY=1 FOR WEST; 2 FOR EAST.
99
100 ! WRITE(0,*)'WESTERN BC FOR PATCH',IDS,MAX(JTS-1,JDS+3-1),MIN(JTE+1,JDE-2)
101 !
102
103 DO IBDY=1,2
104 !
105 !*** MAKE SURE THE PROCESSOR HAS THIS BOUNDARY.
106 !
107 IF((W_BDY.AND.IBDY.EQ.1).OR.(E_BDY.AND.IBDY.EQ.2))THEN
108 IF(IBDY.EQ.1)THEN
109 BF=P_XSB ! Which boundary (XSB=the boundary where X is at its start)
110 IB=1 ! Which cell in from boundary
111 II=1 ! Which cell in the domain
112 ELSE
113 BF=P_XEB ! Which boundary (XEB=the boundary where X is at its end)
114 IB=1 ! Which cell in from boundary
115 II=IDE ! Which cell in the domain
116 ENDIF
117
118 DO J=MAX(JTS-1,JDS+3-1),MIN(JTE+1,JDE-2)
119 IF(MOD(J,2).EQ.1)THEN ! J=3,5,7,9
120 PD_B(J,1,IB,BF) =PDTMP_B(II,J)
121 PD_BT(J,1,IB,BF) =PDTMP_BT(II,J)
122 ENDIF
123 ENDDO
124
125 !
126 DO K=KTS,KTE
127 DO J=MAX(JTS-1,JDS+3-1),MIN(JTE+1,JDE-2)
128 IF(MOD(J,2).EQ.1)THEN ! J=3,5,7,9
129 T_B(J,K,IB,BF) = TTMP_B(II,K,J)
130 T_BT(J,K,IB,BF) = TTMP_BT(II,K,J)
131 Q_B(J,K,IB,BF) = QTMP_B(II,K,J)
132 Q_BT(J,K,IB,BF) = QTMP_BT(II,K,J)
133 Q2_B(J,K,IB,BF) = Q2TMP_B(II,K,J)
134 Q2_BT(J,K,IB,BF) = Q2TMP_BT(II,K,J)
135 CWM_B(J,K,IB,BF) = CWMTMP_B(II,K,J)
136 CWM_BT(J,K,IB,BF) = CWMTMP_BT(II,K,J)
137 ENDIF
138 ENDDO
139 ENDDO
140
141 DO K=KTS,KTE
142 DO J=MAX(JTS-1,JDS+2-1),MIN(JTE+1,JDE-1)
143 IF(MOD(J,2).EQ.0)THEN ! J=2,4,6,8
144 U_B(J,K,IB,BF) = UTMP_B(II,K,J)
145 U_BT(J,K,IB,BF) = UTMP_BT(II,K,J)
146 V_B(J,K,IB,BF) = VTMP_B(II,K,J)
147 V_BT(J,K,IB,BF) = VTMP_BT(II,K,J)
148 ENDIF
149 ENDDO
150 ENDDO
151
152 ENDIF
153 ENDDO
154 !
155 !----------------------------------------------------------------------
156 !*** SOUTH AND NORTH BOUNDARIES
157 !----------------------------------------------------------------------
158 !
159 !*** USE IBDY=1 FOR SOUTH; 2 FOR NORTH
160 !
161 DO IBDY=1,2
162 !
163 !*** MAKE SURE THE PROCESSOR HAS THIS BOUNDARY.
164 !
165 IF((S_BDY.AND.IBDY.EQ.1).OR.(N_BDY.AND.IBDY.EQ.2))THEN
166 !
167 IF(IBDY.EQ.1)THEN
168 BF=P_YSB ! Which boundary (YSB=the boundary where Y is at its start)
169 JB=1 ! Which cell in from boundary
170 JJ=1 ! Which cell in the domain
171 ELSE
172 BF=P_YEB ! Which boundary (YEB=the boundary where Y is at its end)
173 JB=1 ! Which cell in from boundary
174 JJ=JDE ! Which cell in the domain
175 ENDIF
176 !
177 DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
178 PD_B(I,1,JB,BF) = PDTMP_B(I,JJ)
179 PD_BT(I,1,JB,BF)= PDTMP_BT(I,JJ)
180 ENDDO
181
182 !
183 DO K=KTS,KTE
184 DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
185 T_B(I,K,JB,BF) = TTMP_B(I,K,JJ)
186 T_BT(I,K,JB,BF) = TTMP_BT(I,K,JJ)
187 Q_B(I,K,JB,BF) = QTMP_B(I,K,JJ)
188 Q_BT(I,K,JB,BF) = QTMP_BT(I,K,JJ)
189 Q2_B(I,K,JB,BF) = Q2TMP_B(I,K,JJ)
190 Q2_BT(I,K,JB,BF) = Q2TMP_BT(I,K,JJ)
191 CWM_B(I,K,JB,BF) = CWMTMP_B(I,K,JJ)
192 CWM_BT(I,K,JB,BF)= CWMTMP_BT(I,K,JJ)
193 ENDDO
194 ENDDO
195
196 DO K=KTS,KTE
197 DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
198 U_B(I,K,JB,BF) = UTMP_B(I,K,JJ)
199 U_BT(I,K,JB,BF) = UTMP_BT(I,K,JJ)
200 V_B(I,K,JB,BF) = VTMP_B(I,K,JJ)
201 V_BT(I,K,JB,BF) = VTMP_BT(I,K,JJ)
202 ENDDO
203 ENDDO
204
205 ENDIF
206 ENDDO
207 END SUBROUTINE NESTBC_PATCH
208
209 !----------------------------------------------------------------------
210 !
211 SUBROUTINE STATS_FOR_MOVE (XLOC,YLOC,PDYN,MSLP,SQWS &
212 ,PINT,T,Q,U,V &
213 ,FIS,PD,SM,PDTOP,PTOP &
214 ,DETA1,DETA2 &
215 ,MOVED,MVNEST,NTSD,NPHS &
216 ,IDS,IDE,JDS,JDE,KDS,KDE &
217 ,IMS,IME,JMS,JME,KMS,KME &
218 ,ITS,ITE,JTS,JTE,KTS,KTE )
219
220 !**********************************************************************
221 !$$$ SUBPROGRAM DOCUMENTATION BLOCK
222 ! . . .
223 ! SUBPROGRAM: STATS_FOR_MOVE
224 ! PRGRMMR: gopal
225 !
226 ! ABSTRACT:
227 ! THIS ROUTINE COMPUTES SOME STATS REQUIRED FOR AUTOMATIC GRID MOTION
228 ! PROGRAM HISTORY LOG:
229 ! 05-18-2005 : gopal
230 !
231 ! USAGE: CALL STATS_FOR_MOVE FROM SUBROUTINE SOLVE_RUNSTREAM FOR NESTED DOMAIN ONLY
232 !
233 ! ATTRIBUTES:
234 ! LANGUAGE: FORTRAN 90
235 ! MACHINE : IBM SP
236 !$$$
237 !**********************************************************************
238
239 USE MODULE_MODEL_CONSTANTS
240 USE MODULE_DM
241
242 IMPLICIT NONE
243 !
244 LOGICAL,EXTERNAL :: wrf_dm_on_monitor
245 LOGICAL,INTENT(INOUT) :: MVNEST ! NMM SWITCH FOR GRID MOTION
246 LOGICAL,INTENT(IN) :: MOVED
247 INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
248 ,IMS,IME,JMS,JME,KMS,KME &
249 ,ITS,ITE,JTS,JTE,KTS,KTE &
250 ,NTSD,NPHS
251 !
252 INTEGER, INTENT(OUT) :: XLOC,YLOC
253 REAL, DIMENSION(KMS:KME), INTENT(IN) :: DETA1,DETA2
254 REAL, INTENT(IN) :: PDTOP,PTOP
255 REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(IN) :: FIS,PD,SM
256 REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(IN) :: PINT,T,Q,U,V
257 REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(OUT) :: PDYN,MSLP,SQWS
258 !
259 ! LOCAL
260
261 INTEGER,SAVE :: NTIME0
262 INTEGER :: IM,JM,IP,JP
263 INTEGER :: I,K,J,XR,YR,DTMOVE,IDUM,JDUM,ITF,JTF
264 REAL, PARAMETER :: LAPSR=6.5E-3, GI=1./G,D608=0.608
265 REAL, PARAMETER :: COEF3=287.05*GI*LAPSR, COEF2=-1./COEF3
266 REAL, PARAMETER :: TRG=2.0*R_D*GI,LAPSI=1.0/LAPSR
267 REAL :: DZ,RTOPP,APELP,A,TSFC,STMP0,STMP1
268 REAL :: SMSUM,SMOUT,XDIFF,YDIFF,PCUT,PGR
269 REAL :: MINGBL_PDYN,MAXGBL_PDYN,MAXGBL_SQWS
270 REAL :: MINGBL_MIJ
271 REAL, DIMENSION(IMS:IME,JMS:JME) :: MIJ
272 REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: Z
273
274 ! EXEC
275
276 ITF=MIN(ITE,IDE-1)
277 JTF=MIN(JTE,JDE-1)
278
279 !----------------------------------------------------------------------------------
280
281 ! KEEP NEST MOTION IN SINK WITH PHYSICS TIME STEPS
282
283 IF(MOD(NTSD+1,NPHS)/=0)THEN
284 MVNEST=.FALSE.
285 RETURN
286 ENDIF
287
288 WRITE(0,*)'PHYSICS IN SINK',NTSD,NPHS
289
290 ! DETERMINE THE HEIGHTS ON THE PARENT DOMAIN
291
292 DO J = JTS, MIN(JTE,JDE)
293 DO I = ITS, MIN(ITE,IDE)
294 Z(I,1,J)=FIS(I,J)*GI
295 ENDDO
296 ENDDO
297 !
298 DO J = JTS, MIN(JTE,JDE)
299 DO K = KTS,KTE
300 DO I = ITS, MIN(ITE,IDE)
301 APELP = (PINT(I,K+1,J)+PINT(I,K,J))
302 RTOPP = TRG*T(I,K,J)*(1.0+Q(I,K,J)*P608)/APELP
303 DZ = RTOPP*(DETA1(K)*PDTOP+DETA2(K)*PD(I,J))
304 Z(I,K+1,J) = Z(I,K,J) + DZ
305 ENDDO
306 ENDDO
307 ENDDO
308
309 ! DETERMINE THE MEAN SEA LEVEL PRESSURE, THE VERTICALLY AVERAGED WIND
310 ! SPEED AT ABOUT LEVELS 9 10 AND 11 AND THE DYNAMIC PRESSURES DEFINED
311 ! FROM BASIC BERNOULLI's THEOREM
312
313 DO J = JTS, MIN(JTE,JDE)
314 DO I = ITS, MIN(ITE,IDE)
315 TSFC = T(I,1,J)*(1.+D608*Q(I,1,J)) + LAPSR*(Z(I,1,J)+Z(I,2,J))*0.5
316 A = LAPSR*Z(I,1,J)/TSFC
317 MSLP(I,J) = PINT(I,1,J)*(1-A)**COEF2
318 SQWS(I,J) = (U(I,9,J)*U(I,9,J) + V(I,9,J)*V(I,9,J) &
319 + U(I,10,J)*U(I,10,J) + V(I,10,J)*V(I,10,J) &
320 + U(I,11,J)*U(I,11,J) + V(I,11,J)*V(I,11,J))/3.0
321 PDYN(I,J) = MSLP(I,J) + 1.1*SQWS(I,J)/2.0
322 ENDDO
323 ENDDO
324
325 ! FILTER OUT PDYN AND STORE THAT IN MIJ. THE MAXIMUM VALUE OF MIJ GIVES THE STORM CENTER
326 ! ALSO DO THAT WITHIN A SUB DOMAIN
327
328 MAXGBL_PDYN=MAXVAL(PDYN(ITS:ITF,JTS:JTF))
329 CALL WRF_DM_MAXVAL(MAXGBL_PDYN,IDUM,JDUM)
330 MINGBL_PDYN=MINVAL(PDYN(ITS:ITF,JTS:JTF))
331 CALL WRF_DM_MINVAL(MINGBL_PDYN,IDUM,JDUM)
332 PCUT = 0.5*(MAXGBL_PDYN + MINGBL_PDYN)
333 !
334 IM=IDE/2 - IDE/6
335 IP=IDE/2 + IDE/6
336 JM=JDE/2 - JDE/4
337 JP=JDE/2 + JDE/4
338 !
339 DO J = JTS, MIN(JTE,JDE)
340 DO I = ITS, MIN(ITE,IDE)
341 IF(I .GE. IM .AND. I .LE. IP .AND. J .GE. JM .AND. J .LE. JP &
342 .AND. PCUT .GT. PDYN(I,J))THEN
343 MIJ(I,J) = PDYN(I,J)
344 ELSE
345 MIJ(I,J) = 105000.
346 ENDIF
347 ENDDO
348 ENDDO
349
350 DO J = JTS, MIN(JTE,JDE)
351 DO I = ITS, MIN(ITE,IDE)
352 PDYN(I,J)=MIJ(I,J)
353 ENDDO
354 ENDDO
355
356 ! DETERMINE THE LOCATION OF CENTER OF THE CIRCULATION DEFINED BY MIJ AND FIND THE CORRESPONDING MSLP
357
358 MINGBL_MIJ=MINVAL(MIJ(ITS:ITF,JTS:JTF))
359 DO J = JTS, MIN(JTE,JDE)
360 DO I = ITS, MIN(ITE,IDE)
361 IF(MIJ(I,J) .EQ. MINGBL_MIJ)THEN
362 XLOC=I
363 YLOC=J
364 STMP0=MSLP(I,J)
365 ENDIF
366 ENDDO
367 ENDDO
368
369 CALL WRF_DM_MINVAL(MINGBL_MIJ,XLOC,YLOC)
370 CALL WRF_DM_MINVAL(STMP0,IDUM,JDUM)
371
372 ! DETERMINE THE MAXIMUM MSLP AT ABOUT 18 GRID POINTS AWAY FROM THE STORM CENTER
373
374 DO J = JTS, MIN(JTE,JDE)
375 DO I = ITS, MIN(ITE,IDE)
376 IF(I .EQ. XLOC+18)THEN
377 XR=I
378 YR=J
379 STMP1=MSLP(I,J)
380 ENDIF
381 ENDDO
382 ENDDO
383
384 CALL WRF_DM_MAXVAL(STMP1,XR,YR)
385
386 !
387 ! DETERMINE IF THE ENTIRE NESTED DOMAIN IS OVER LAND (SM=0)
388 !
389
390 SMSUM = 0.0
391 DO J = JTS, MIN(JTE,JDE)
392 DO I = ITS, MIN(ITE,IDE)
393 SMSUM = SMSUM + SM(I,J)
394 ENDDO
395 ENDDO
396
397 SMOUT=WRF_DM_SUM_REAL(SMSUM)/(IDE*JDE)
398
399 ! STOP GRID MOTION. AVOID MOVING TOO RAPID GRID MOTION, SAY SOMETHING LIKE EVERY
400 ! OTHER TIME STEP OR SO
401
402 PGR=STMP1-STMP0
403 XDIFF=ABS(XLOC - IDE/2)
404 YDIFF=ABS(YLOC - JDE/2)
405 IF(NTSD==0 .OR. MOVED)NTIME0=NTSD
406 DTMOVE=NTSD-NTIME0 ! TIME INTERVAL SINCE THE PREVIOUS MOVE
407 !
408 IF(DTMOVE .LE. 45 .OR. PGR .LE. 200.)THEN
409 WRITE(0,*)'SUSPEND MOTION: SMALL DTMOVE OR WEAK PGF:','DTMOVE=',DTMOVE,'PGR=',PGR
410 MVNEST=.FALSE. ! SET STATIC GRID
411 ELSE IF(STMP0 .GE. STMP1)THEN
412 WRITE(0,*)'SUSPEND MOTION: THERE IS NO VORTEX IN THE DOMAIN:','STMP0=',STMP0,'STMP1=',STMP1
413 MVNEST=.FALSE.
414 ELSE IF(XDIFF .GT. 24 .OR. YDIFF .GT. 24)THEN
415 WRITE(0,*)'SUSPEND MOTION: LOST VORTEX ','DTMOVE=',DTMOVE,'XDIFF=',XDIFF,'YDIFF=',YDIFF
416 MVNEST=.FALSE.
417 ELSE IF(SMOUT .LE. 0.2 .AND. XDIFF .GT. 12 .AND. YDIFF .GT. 12)THEN
418 WRITE(0,*)'SUSPEND MOTION: VORTEX LOST OVER LAND ','DTMOVE=',DTMOVE,'XDIFF=',XDIFF,'YDIFF=',YDIFF
419 MVNEST=.FALSE.
420 ELSE IF(SMOUT .LE. 0.2 .AND. PGR .LE. 400.)THEN
421 WRITE(0,*)'SUSPEND MOTION: VORTEX WEAK OVER LAND ','SMOUT=',SMOUT,'PGR=',PGR
422 MVNEST=.FALSE.
423 ELSE IF(SMOUT .LE. 0.2 .AND. DTMOVE .GE. 1500)THEN
424 WRITE(0,*)'SUSPEND MOTION: STOP MOTION OVER LAND','SMOUT=',SMOUT,'DTMOVE=',DTMOVE
425 MVNEST=.FALSE.
426 ELSE
427 MVNEST=.TRUE.
428 ENDIF
429
430 RETURN
431
432 END SUBROUTINE STATS_FOR_MOVE
433 !----------------------------------------------------------------------------------
434
435 END MODULE module_NEST_UTIL
436