wrfv2_fire/dyn_em/nest_init_utils.F

   1 SUBROUTINE init_domain_constants_em ( parent , nest )
   2    USE module_domain, ONLY : domain
   3    IMPLICIT NONE
   4    TYPE(domain)  :: parent , nest
   5
   6    INTEGER iswater , map_proj, julyr, julday
   7    REAL    truelat1 , truelat2 , gmt , moad_cen_lat , stand_lon, pole_lat, pole_lon
   8    CHARACTER (LEN=256) :: char_junk
   9
  10 ! single-value constants
  11
  12    nest%p_top   = parent%p_top
  13    nest%save_topo_from_real   = parent%save_topo_from_real
  14    nest%cfn     = parent%cfn
  15    nest%cfn1    = parent%cfn1
  16    nest%rdx     = 1./nest%dx
  17    nest%rdy     = 1./nest%dy
  18 !  nest%dts     = nest%dt/float(nest%time_step_sound)
  19    nest%dtseps  = parent%dtseps  ! used in height model only?
  20    nest%resm    = parent%resm    ! used in height model only?
  21    nest%zetatop = parent%zetatop ! used in height model only?
  22    nest%cf1     = parent%cf1
  23    nest%cf2     = parent%cf2
  24    nest%cf3     = parent%cf3
  25    nest%gmt     = parent%gmt
  26    nest%julyr   = parent%julyr
  27    nest%julday  = parent%julday
  28
  29    CALL nl_get_mminlu ( 1,char_junk(1:256) )
  30    CALL nl_get_iswater (1, iswater )
  31    CALL nl_get_truelat1 ( 1 , truelat1 )
  32    CALL nl_get_truelat2 ( 1 , truelat2 )
  33    CALL nl_get_moad_cen_lat ( 1 , moad_cen_lat )
  34    CALL nl_get_stand_lon ( 1 , stand_lon )
  35    CALL nl_get_pole_lat ( 1 , pole_lat )
  36    CALL nl_get_pole_lon ( 1 , pole_lon )
  37    CALL nl_get_map_proj ( 1 , map_proj )
  38    CALL nl_get_gmt ( 1 , gmt)
  39    CALL nl_get_julyr ( 1 , julyr)
  40    CALL nl_get_julday ( 1 , julday)
  41    IF ( nest%id .NE. 1 ) THEN
  42      CALL nl_set_gmt (nest%id, gmt)
  43      CALL nl_set_julyr (nest%id, julyr)
  44      CALL nl_set_julday (nest%id, julday)
  45      CALL nl_set_iswater (nest%id, iswater )
  46      CALL nl_set_truelat1 ( nest%id , truelat1 )
  47      CALL nl_set_truelat2 ( nest%id , truelat2 )
  48      CALL nl_set_moad_cen_lat ( nest%id , moad_cen_lat )
  49      CALL nl_set_stand_lon ( nest%id , stand_lon )
  50      CALL nl_set_pole_lat ( nest%id , pole_lat )
  51      CALL nl_set_pole_lon ( nest%id , pole_lon )
  52      CALL nl_set_map_proj ( nest%id , map_proj )
  53    END IF
  54    nest%gmt     = gmt
  55    nest%julday  = julday
  56    nest%julyr   = julyr
  57    nest%iswater = iswater
  58    nest%truelat1= truelat1
  59    nest%truelat2= truelat2
  60    nest%moad_cen_lat= moad_cen_lat
  61    nest%stand_lon= stand_lon
  62    nest%pole_lat= pole_lat
  63    nest%pole_lon= pole_lon
  64    nest%map_proj= map_proj
  65
  66    nest%step_number  = parent%step_number
  67
  68 ! 1D constants (Z)
  69
  70    nest%fnm    = parent%fnm
  71    nest%fnp    = parent%fnp
  72    nest%rdnw   = parent%rdnw
  73    nest%rdn    = parent%rdn
  74    nest%dnw    = parent%dnw
  75    nest%dn     = parent%dn
  76    nest%znu    = parent%znu
  77    nest%znw    = parent%znw
  78    nest%t_base = parent%t_base
  79    nest%u_base    = parent%u_base
  80    nest%v_base    = parent%v_base
  81    nest%qv_base   = parent%qv_base
  82    nest%z_base    = parent%z_base
  83    nest%dzs       = parent%dzs
  84    nest%zs        = parent%zs
  85
  86 END SUBROUTINE init_domain_constants_em
  87
  88 SUBROUTINE blend_terrain ( ter_interpolated , ter_input , &
  89                            ids , ide , jds , jde , kds , kde , &
  90                            ims , ime , jms , jme , kms , kme , &
  91                            ips , ipe , jps , jpe , kps , kpe )
  92
  93    USE module_configure
  94    IMPLICIT NONE
  95
  96    INTEGER , INTENT(IN)                       :: ids , ide , jds , jde , kds , kde , &
  97                                                  ims , ime , jms , jme , kms , kme , &
  98                                                  ips , ipe , jps , jpe , kps , kpe
  99    REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN)    :: ter_interpolated
 100    REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(INOUT) :: ter_input
 101
 102    REAL , DIMENSION(ims:ime,kms:kme,jms:jme) :: ter_temp
 103    INTEGER :: i , j , k , spec_bdy_width
 104    REAL    :: r_blend_zones
 105    INTEGER blend_cell, blend_width
 106
 107    !  The fine grid elevation comes from the horizontally interpolated
 108    !  parent elevation for the first spec_bdy_width row/columns, so we need
 109    !  to get that value.  We blend the coarse and fine in the next blend_width
 110    !  rows and columns.  After that, in the interior, it is 100% fine grid.
 111
 112    CALL nl_get_spec_bdy_width ( 1, spec_bdy_width)
 113    CALL nl_get_blend_width ( 1, blend_width)
 114
 115    !  Initialize temp values to the nest ter elevation.  This fills in the values
 116    !  that will not be modified below.
 117
 118    DO j = jps , MIN(jpe, jde-1)
 119       DO k = kps , kpe
 120          DO i = ips , MIN(ipe, ide-1)
 121             ter_temp(i,k,j) = ter_input(i,k,j)
 122          END DO
 123       END DO
 124    END DO
 125
 126    !  To avoid some tricky indexing, we fill in the values inside out.  This allows
 127    !  us to overwrite incorrect assignments.  There are replicated assignments, and
 128    !  there is much unnecessary "IF test inside of a loop" stuff.  For a large
 129    !  domain, this is only a patch; for a small domain, this is not a biggy.
 130
 131    r_blend_zones = 1./(blend_width+1)
 132    DO j = jps , MIN(jpe, jde-1)
 133       DO k = kps , kpe
 134          DO i = ips , MIN(ipe, ide-1)
 135             DO blend_cell = blend_width,1,-1
 136                IF   ( ( i .EQ.       spec_bdy_width + blend_cell ) .OR.  ( j .EQ.       spec_bdy_width + blend_cell ) .OR. &
 137                       ( i .EQ. ide - spec_bdy_width - blend_cell ) .OR.  ( j .EQ. jde - spec_bdy_width - blend_cell ) ) THEN
 138                   ter_temp(i,k,j) = ( (blend_cell)*ter_input(i,k,j) + (blend_width+1-blend_cell)*ter_interpolated(i,k,j) ) &
 139                                     * r_blend_zones
 140                END IF
 141             ENDDO
 142             IF      ( ( i .LE.       spec_bdy_width     ) .OR.  ( j .LE.       spec_bdy_width     ) .OR. &
 143                       ( i .GE. ide - spec_bdy_width     ) .OR.  ( j .GE. jde - spec_bdy_width     ) ) THEN
 144                ter_temp(i,k,j) =      ter_interpolated(i,k,j)
 145             END IF
 146          END DO
 147       END DO
 148    END DO
 149
 150    !  Set nest elevation with temp values.  All values not overwritten in the above
 151    !  loops have been previously set in the initial assignment.
 152
 153    DO j = jps , MIN(jpe, jde-1)
 154       DO k = kps , kpe
 155          DO i = ips , MIN(ipe, ide-1)
 156             ter_input(i,k,j) = ter_temp(i,k,j)
 157          END DO
 158       END DO
 159    END DO
 160
 161 END SUBROUTINE blend_terrain
 162
 163 SUBROUTINE copy_3d_field ( ter_interpolated , ter_input , &
 164                            ids , ide , jds , jde , kds , kde , &
 165                            ims , ime , jms , jme , kms , kme , &
 166                            ips , ipe , jps , jpe , kps , kpe )
 167
 168    IMPLICIT NONE
 169
 170    INTEGER , INTENT(IN)                       :: ids , ide , jds , jde , kds , kde , &
 171                                                  ims , ime , jms , jme , kms , kme , &
 172                                                  ips , ipe , jps , jpe , kps , kpe
 173    REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(OUT) :: ter_interpolated
 174    REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN)  :: ter_input
 175
 176    INTEGER :: i , j , k
 177
 178    DO j = jps , MIN(jpe, jde-1)
 179       DO k = kps , kpe
 180          DO i = ips , MIN(ipe, ide-1)
 181             ter_interpolated(i,k,j) = ter_input(i,k,j)
 182          END DO
 183       END DO
 184    END DO
 185
 186 END SUBROUTINE copy_3d_field
 187
 188 SUBROUTINE adjust_tempqv ( mub, save_mub, znw, p_top, &
 189                            th, pp, qv,  &
 190                            ids , ide , jds , jde , kds , kde , &
 191                            ims , ime , jms , jme , kms , kme , &
 192                            ips , ipe , jps , jpe , kps , kpe )
 193
 194    !USE module_configure
 195    !USE module_domain
 196    USE module_model_constants
 197
 198    !USE module_bc
 199    !USE module_io_domain
 200    !USE module_state_description
 201    !USE module_timing
 202    !USE module_soil_pre
 203    IMPLICIT NONE
 204
 205    INTEGER , INTENT(IN)                       :: ids , ide , jds , jde , kds , kde , &
 206                                                  ims , ime , jms , jme , kms , kme , &
 207                                                  ips , ipe , jps , jpe , kps , kpe
 208    REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN)    :: mub, save_mub
 209    REAL , DIMENSION(kms:kme) , INTENT(IN)    :: znw
 210    REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(INOUT) :: th, pp, qv
 211
 212    REAL , DIMENSION(ims:ime,kms:kme,jms:jme) :: p_old, p_new, rh
 213    REAL :: es,dth,tc,e,dth1
 214    INTEGER :: i , j , k
 215
 216    real p_top
 217
 218
 219 ! p_old = full pressure before terrain blending; also compute initial RH
 220 ! which is going to be conserved during terrain blending
 221    DO j = jps , MIN(jpe, jde-1)
 222       DO k = kps , kpe-1
 223          DO i = ips , MIN(ipe, ide-1)
 224             p_old(i,k,j) = 0.5*(znw(k+1)+znw(k))*save_mub(i,j) + p_top + pp(i,k,j)
 225             tc = (th(i,k,j)+300.)*(p_old(i,k,j)/1.e5)**(2./7.) - 273.15
 226             es = 610.78*exp(17.0809*tc/(234.175+tc))
 227             e = qv(i,k,j)*p_old(i,k,j)/(0.622+qv(i,k,j))
 228             rh(i,k,j) = e/es
 229          END DO
 230       END DO
 231    END DO
 232
 233 ! p_new = full pressure after terrain blending; also compute temperature correction and convert RH back to QV
 234    DO j = jps , MIN(jpe, jde-1)
 235       DO k = kps , kpe-1
 236          DO i = ips , MIN(ipe, ide-1)
 237             p_new(i,k,j) = 0.5*(znw(k+1)+znw(k))*mub(i,j) + p_top + pp(i,k,j)
 238 ! 2*(g/cp-6.5e-3)*R_dry/g = -191.86e-3
 239             dth1 = -191.86e-3*(th(i,k,j)+300.)/(p_new(i,k,j)+p_old(i,k,j))*(p_new(i,k,j)-p_old(i,k,j))
 240             dth = -191.86e-3*(th(i,k,j)+0.5*dth1+300.)/(p_new(i,k,j)+p_old(i,k,j))*(p_new(i,k,j)-p_old(i,k,j))
 241             th(i,k,j) = th(i,k,j)+dth
 242             tc = (th(i,k,j)+300.)*(p_new(i,k,j)/1.e5)**(2./7.) - 273.15
 243             es = 610.78*exp(17.0809*tc/(234.175+tc))
 244             e = rh(i,k,j)*es
 245             qv(i,k,j) = 0.622*e/(p_new(i,k,j)-e)
 246          END DO
 247       END DO
 248    END DO
 249
 250
 251 END SUBROUTINE adjust_tempqv
 252
 253 SUBROUTINE input_terrain_rsmas ( grid ,                        &
 254                            ids , ide , jds , jde , kds , kde , &
 255                            ims , ime , jms , jme , kms , kme , &
 256                            ips , ipe , jps , jpe , kps , kpe )
 257
 258    USE module_domain, ONLY : domain
 259    IMPLICIT NONE
 260    TYPE ( domain ) :: grid
 261
 262    INTEGER , INTENT(IN)                       :: ids , ide , jds , jde , kds , kde , &
 263                                                  ims , ime , jms , jme , kms , kme , &
 264                                                  ips , ipe , jps , jpe , kps , kpe
 265
 266    LOGICAL, EXTERNAL ::  wrf_dm_on_monitor
 267
 268    INTEGER :: i , j , k , myproc
 269    INTEGER, DIMENSION(256) :: ipath  ! array for integer coded ascii for passing path down to get_terrain
 270    CHARACTER*256 :: message, message2
 271    CHARACTER*256 :: rsmas_data_path
 272
 273 #if DM_PARALLEL
 274 ! Local globally sized arrays
 275    REAL , DIMENSION(ids:ide,jds:jde) :: ht_g, xlat_g, xlon_g
 276 #endif
 277
 278    CALL wrf_get_myproc ( myproc )
 279
 280 #if 0
 281 CALL domain_clock_get ( grid, current_timestr=message2 )
 282 WRITE ( message , FMT = '(A," HT before ",I3)' ) TRIM(message2), grid%id
 283 write(30+myproc,*)ipe-ips+1,jpe-jps+1,trim(message)
 284 do j = jps,jpe
 285 do i = ips,ipe
 286 write(30+myproc,*)grid%ht(i,j)
 287 enddo
 288 enddo
 289 #endif
 290
 291    CALL nl_get_rsmas_data_path(1,rsmas_data_path)
 292    do i = 1, LEN(TRIM(rsmas_data_path))
 293       ipath(i) = ICHAR(rsmas_data_path(i:i))
 294    enddo
 295
 296 #if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
 297
 298    CALL wrf_patch_to_global_real ( grid%xlat , xlat_g , grid%domdesc, ' ' , 'xy' ,       &
 299                                    ids, ide-1 , jds , jde-1 , 1 , 1 , &
 300                                    ims, ime   , jms , jme   , 1 , 1 , &
 301                                    ips, ipe   , jps , jpe   , 1 , 1   )
 302    CALL wrf_patch_to_global_real ( grid%xlong , xlon_g , grid%domdesc, ' ' , 'xy' ,       &
 303                                    ids, ide-1 , jds , jde-1 , 1 , 1 , &
 304                                    ims, ime   , jms , jme   , 1 , 1 , &
 305                                    ips, ipe   , jps , jpe   , 1 , 1   )
 306
 307    IF ( wrf_dm_on_monitor() ) THEN
 308      CALL get_terrain ( grid%dx/1000., xlat_g(ids:ide,jds:jde), xlon_g(ids:ide,jds:jde), ht_g(ids:ide,jds:jde), &
 309                         ide-ids+1,jde-jds+1,ide-ids+1,jde-jds+1, ipath, LEN(TRIM(rsmas_data_path)) )
 310      WHERE ( ht_g(ids:ide,jds:jde) < -1000. ) ht_g(ids:ide,jds:jde) = 0.
 311    ENDIF
 312
 313    CALL wrf_global_to_patch_real ( ht_g , grid%ht , grid%domdesc, ' ' , 'xy' ,         &
 314                                    ids, ide-1 , jds , jde-1 , 1 , 1 , &
 315                                    ims, ime   , jms , jme   , 1 , 1 , &
 316                                    ips, ipe   , jps , jpe   , 1 , 1   )
 317 #else
 318
 319    CALL get_terrain ( grid%dx/1000., grid%xlat(ids:ide,jds:jde), grid%xlong(ids:ide,jds:jde), grid%ht(ids:ide,jds:jde), &
 320                        ide-ids+1,jde-jds+1,ide-ids+1,jde-jds+1, ipath, LEN(TRIM(rsmas_data_path)) )
 321    WHERE ( grid%ht(ids:ide,jds:jde) < -1000. ) grid%ht(ids:ide,jds:jde) = 0.
 322
 323 #endif
 324
 325 #if 0
 326 CALL domain_clock_get ( grid, current_timestr=message2 )
 327 WRITE ( message , FMT = '(A," HT after ",I3)' ) TRIM(message2), grid%id
 328 write(30+myproc,*)ipe-ips+1,jpe-jps+1,trim(message)
 329 do j = jps,jpe
 330 do i = ips,ipe
 331 write(30+myproc,*)grid%ht(i,j)
 332 enddo
 333 enddo
 334 #endif
 335
 336 END SUBROUTINE input_terrain_rsmas
 337
 338 SUBROUTINE update_after_feedback_em ( grid  &
 339 !
 340 #include "dummy_new_args.inc"
 341 !
 342                  )
 343 !
 344 ! perform core specific updates, exchanges after
 345 ! model feedback  (called from med_feedback_domain) -John
 346 !
 347
 348 ! Driver layer modules
 349    USE module_domain, ONLY : domain, get_ijk_from_grid
 350    USE module_configure
 351    USE module_driver_constants
 352    USE module_machine
 353    USE module_tiles
 354 #ifdef DM_PARALLEL
 355    USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask
 356    USE module_comm_dm, ONLY : HALO_EM_FEEDBACK_sub
 357 #else
 358    USE module_dm
 359 #endif
 360    USE module_bc
 361 ! Mediation layer modules
 362 ! Registry generated module
 363    USE module_state_description
 364
 365    IMPLICIT NONE
 366
 367    !  Subroutine interface block.
 368
 369    TYPE(domain) , TARGET         :: grid
 370
 371    !  Definitions of dummy arguments
 372 #include <dummy_new_decl.inc>
 373
 374    INTEGER                         :: ids , ide , jds , jde , kds , kde , &
 375                                       ims , ime , jms , jme , kms , kme , &
 376                                       ips , ipe , jps , jpe , kps , kpe
 377
 378   CALL wrf_debug( 500, "entering update_after_feedback_em" )
 379
 380 !  Obtain dimension information stored in the grid data structure.
 381   CALL get_ijk_from_grid (  grid ,                   &
 382                             ids, ide, jds, jde, kds, kde,    &
 383                             ims, ime, jms, jme, kms, kme,    &
 384                             ips, ipe, jps, jpe, kps, kpe    )
 385
 386   CALL wrf_debug( 500, "before HALO_EM_FEEDBACK.inc in update_after_feedback_em" )
 387 #ifdef DM_PARALLEL
 388 #include "HALO_EM_FEEDBACK.inc"
 389 #endif
 390   CALL wrf_debug( 500, "leaving update_after_feedback_em" )
 391
 392 END SUBROUTINE update_after_feedback_em
 393