wrfv2_fire/dyn_nmm/module_NEST_UTIL.F

   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          & ! CFREQ*DT*NPHS=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.05*GI*LAPSR, COEF2=-1./COEF3
 397       REAL, PARAMETER                                       :: TRG=2.0*R_D*GI,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      = TRG*T(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.+D608*Q(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.05*GI*LAPSR, COEF2=-1./COEF3
 668       REAL, PARAMETER                                       :: TRG=2.0*R_D*GI,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      = TRG*T(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.+D608*Q(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