wrfv2_fire/main/nup_em.F

   1 !WRF:DRIVER_LAYER:MAIN
   2 !
   3
   4 ! "Nest up" program in WRFV2.
   5 !
   6 ! Description:
   7 !
   8 ! The nest up (nup.exe) program reads from wrfout_d02_<date> files for
   9 ! the nest and generates wrfout_d01_<date> files for the same periods as
  10 ! are in the input files.  The fields in the output are the fields in the
  11 ! input for state variables that have 'h' and 'u' in the I/O string of
  12 ! the Registry.  In other words, these are the fields that are normally
  13 ! fed back from nest->parent during 2-way nesting.  It will read and
  14 ! output over multiple files of nest data and generate an equivalent
  15 ! number of files of parent data.  The dimensions of the fields in the
  16 ! output are the size of the nest fields divided by the nesting ratio.
  17 !
  18 ! Source file:   main/nup_em.F
  19 !
  20 ! Compile with WRF: compile em_real
  21 !
  22 ! Resulting executable:
  23 !
  24 !     main/nup.exe
  25 !      -and-
  26 !     symbolic link in test/em_real/nup.exe
  27 !
  28 ! Run as:  nup.exe (no arguments)
  29 !
  30 ! Namelist information:
  31 !
  32 ! Nup.exe uses the same namelist as a nested run of the wrf.exe.
  33 ! Important settings are:
  34 !
  35 !  &time_control
  36 !
  37 !    start_*            <start time information for both domains>
  38 !    end_*              <start time information for both domains>
  39 !    history_interval   <interval between frames in input/output files>
  40 !    frames_per_outfile <number of frames in input/output files>
  41 !    io_form_history    <2 for NetCDF>
  42 !
  43 !  &domains
  44 !     ...
  45 !    max_dom            <number of domains; must be 2>
  46 !    e_we               <col 2 is size of nested grid in west-east>
  47 !                       <col 1 is ignored in the namelist>
  48 !    e_sn               <col 2 is size of nested grid in south-north>
  49 !                       <col 1 is ignored in the namelist>
  50 !    parent_grid_ratio  <col 2 is nesting ratio in both dims>
  51 !    feedback           <must be 1>
  52 !    smooth_option      <recommend 0>
  53 !
  54 !  &physics
  55 !             <all options in this section should be the same
  56 !              as the run that generated the nest data>
  57 !
  58 !  created: JM 2006 01 25
  59
  60 PROGRAM nup_em
  61
  62    USE module_machine
  63    USE module_domain, ONLY : domain, wrfu_timeinterval, alloc_and_configure_domain, &
  64       domain_clock_set, domain_get_current_time, domain_get_stop_time, head_grid, &
  65       domain_clock_get, domain_clockadvance
  66    USE module_domain_type, ONLY : program_name
  67    USE module_streams
  68    USE module_initialize_real, only : wrfu_initialize
  69    USE module_integrate
  70    USE module_driver_constants
  71    USE module_configure, only : grid_config_rec_type, model_config_rec
  72    USE module_io_domain
  73    USE module_utility
  74
  75    USE module_timing
  76    USE module_wrf_error
  77 #ifdef DM_PARALLEL
  78    USE module_dm
  79 #endif
  80 !  USE read_util_module
  81
  82 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  83 !new for bc
  84    USE module_bc
  85    USE module_big_step_utilities_em
  86    USE module_get_file_names
  87 #ifdef WRF_CHEM
  88 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  89 ! for chemistry
  90    USE module_input_chem_data
  91 !  USE module_input_chem_bioemiss
  92 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  93 #endif
  94
  95    IMPLICIT NONE
  96  ! interface
  97    INTERFACE
  98      ! mediation-supplied
  99      SUBROUTINE med_read_wrf_chem_bioemiss ( grid , config_flags)
 100        USE module_domain
 101        TYPE (domain) grid
 102        TYPE (grid_config_rec_type) config_flags
 103      END SUBROUTINE med_read_wrf_chem_bioemiss
 104      SUBROUTINE nup ( parent_grid , nested_grid, in_id, out_id, newly_opened )
 105        USE module_domain
 106        TYPE (domain), POINTER :: parent_grid, nested_grid
 107        INTEGER, INTENT(IN) :: in_id, out_id    ! io units
 108        LOGICAL, INTENT(IN) :: newly_opened     ! whether to add global metadata
 109      END SUBROUTINE nup
 110
 111    END INTERFACE
 112
 113    TYPE(WRFU_TimeInterval) :: RingInterval
 114
 115 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 116 !new for bc
 117    INTEGER :: ids , ide , jds , jde , kds , kde
 118    INTEGER :: ims , ime , jms , jme , kms , kme
 119    INTEGER :: ips , ipe , jps , jpe , kps , kpe
 120    INTEGER :: its , ite , jts , jte , kts , kte
 121    INTEGER :: ijds , ijde , spec_bdy_width
 122    INTEGER :: i , j , k
 123    INTEGER :: time_loop_max , time_loop
 124    INTEGER :: total_time_sec , file_counter
 125    INTEGER :: julyr , julday , iswater , map_proj
 126    INTEGER :: icnt
 127
 128    REAL    :: dt , new_bdy_frq
 129    REAL    :: gmt , cen_lat , cen_lon , dx , dy , truelat1 , truelat2 , moad_cen_lat , stand_lon
 130
 131    REAL , DIMENSION(:,:,:) , ALLOCATABLE :: ubdy3dtemp1 , vbdy3dtemp1 , tbdy3dtemp1 , pbdy3dtemp1 , qbdy3dtemp1
 132    REAL , DIMENSION(:,:,:) , ALLOCATABLE :: mbdy2dtemp1
 133    REAL , DIMENSION(:,:,:) , ALLOCATABLE :: ubdy3dtemp2 , vbdy3dtemp2 , tbdy3dtemp2 , pbdy3dtemp2 , qbdy3dtemp2
 134    REAL , DIMENSION(:,:,:) , ALLOCATABLE :: mbdy2dtemp2
 135
 136    CHARACTER(LEN=19) :: start_timestr , current_timestr , end_timestr, timestr
 137    CHARACTER(LEN=19) :: stopTimeStr
 138
 139 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 140
 141    INTEGER :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat
 142
 143    REAL    :: time
 144    INTEGER :: rc
 145
 146    INTEGER :: loop , levels_to_process
 147    INTEGER , PARAMETER :: max_sanity_file_loop = 100
 148
 149    TYPE (domain) , POINTER :: keep_grid, grid_ptr, null_domain, parent_grid , nested_grid
 150    TYPE (domain)           :: dummy
 151    TYPE (grid_config_rec_type)              :: config_flags
 152    INTEGER                 :: number_at_same_level
 153    INTEGER                 :: time_step_begin_restart
 154
 155    INTEGER :: max_dom , domain_id , fid , fido, fidb , idum1 , idum2 , ierr
 156    INTEGER :: status_next_var
 157    INTEGER :: debug_level
 158    LOGICAL :: newly_opened
 159    CHARACTER (LEN=19) :: date_string
 160
 161 #ifdef DM_PARALLEL
 162    INTEGER                 :: nbytes
 163    INTEGER, PARAMETER      :: configbuflen = 4* CONFIG_BUF_LEN
 164    INTEGER                 :: configbuf( configbuflen )
 165    LOGICAL , EXTERNAL      :: wrf_dm_on_monitor
 166 #endif
 167
 168    INTEGER                 :: idsi, in_id, out_id
 169    INTEGER                 :: e_sn, e_we, pgr
 170    CHARACTER (LEN=80)      :: inpname , outname , bdyname
 171    CHARACTER (LEN=80)      :: si_inpname
 172    CHARACTER *19 :: temp19
 173    CHARACTER *24 :: temp24 , temp24b
 174    CHARACTER *132 :: fname
 175    CHARACTER(len=24) :: start_date_hold
 176
 177    CHARACTER (LEN=80)      :: message
 178 integer :: ii
 179
 180 #include "version_decl"
 181
 182    !  Interface block for routine that passes pointers and needs to know that they
 183    !  are receiving pointers.
 184
 185    INTERFACE
 186
 187       SUBROUTINE med_feedback_domain ( parent_grid , nested_grid )
 188          USE module_domain
 189          USE module_configure
 190          TYPE(domain), POINTER :: parent_grid , nested_grid
 191       END SUBROUTINE med_feedback_domain
 192
 193       SUBROUTINE Setup_Timekeeping( parent_grid )
 194          USE module_domain
 195          TYPE(domain), POINTER :: parent_grid
 196       END SUBROUTINE Setup_Timekeeping
 197
 198    END INTERFACE
 199
 200    !  Define the name of this program (program_name defined in module_domain)
 201
 202    program_name = "NUP_EM " // TRIM(release_version) // " PREPROCESSOR"
 203
 204 #ifdef DM_PARALLEL
 205    CALL disable_quilting
 206 #endif
 207
 208    !  Initialize the modules used by the WRF system.  Many of the CALLs made from the
 209    !  init_modules routine are NO-OPs.  Typical initializations are: the size of a
 210    !  REAL, setting the file handles to a pre-use value, defining moisture and
 211    !  chemistry indices, etc.
 212
 213    CALL init_modules(1)   ! Phase 1 returns after MPI_INIT() (if it is called)
 214 #ifdef NO_LEAP_CALENDAR
 215    CALL WRFU_Initialize( defaultCalKind=WRFU_CAL_NOLEAP, rc=rc )
 216 #else
 217    CALL WRFU_Initialize( defaultCalKind=WRFU_CAL_GREGORIAN, rc=rc )
 218 #endif
 219    CALL init_modules(2)   ! Phase 2 resumes after MPI_INIT() (if it is called)
 220
 221    !  Get the NAMELIST data.  This is handled in the initial_config routine.  All of the
 222    !  NAMELIST input variables are assigned to the model_config_rec structure.  Below,
 223    !  note for parallel processing, only the monitor processor handles the raw Fortran
 224    !  I/O, and then broadcasts the info to each of the other nodes.
 225
 226 #ifdef DM_PARALLEL
 227    IF ( wrf_dm_on_monitor() ) THEN
 228      CALL initial_config
 229    ENDIF
 230    CALL get_config_as_buffer( configbuf, configbuflen, nbytes )
 231    CALL wrf_dm_bcast_bytes( configbuf, nbytes )
 232    CALL set_config_as_buffer( configbuf, configbuflen )
 233    CALL wrf_dm_initialize
 234 #else
 235    CALL initial_config
 236 #endif
 237
 238    !  And here is an instance of using the information in the NAMELIST.
 239
 240    CALL nl_get_debug_level ( 1, debug_level )
 241    CALL set_wrf_debug_level ( debug_level )
 242
 243    ! set the specified boundary to zero so the feedback goes all the way
 244    ! to the edge of the coarse domain
 245    CALL nl_set_spec_zone( 1, 0 )
 246
 247    !  Allocated and configure the mother domain.  Since we are in the nesting down
 248    !  mode, we know a) we got a nest, and b) we only got 1 nest.
 249
 250    NULLIFY( null_domain )
 251
 252 !!!! set up the parent grid  (for nup_em, this is the grid we do output from)
 253
 254    CALL       nl_set_shw( 1, 0 )
 255    CALL       nl_set_shw( 2, 0 )
 256    CALL       nl_set_i_parent_start( 2, 1 )
 257    CALL       nl_set_j_parent_start( 2, 1 )
 258    CALL       nl_get_e_we( 2, e_we )
 259    CALL       nl_get_e_sn( 2, e_sn )
 260    CALL       nl_get_parent_grid_ratio( 2, pgr )
 261
 262    ! parent grid must cover the entire nest, which is always dimensioned a factor of 3 + 1
 263    ! so add two here temporarily, then remove later after nest is allocated.
 264
 265    e_we = e_we / pgr + 2
 266    e_sn = e_sn / pgr + 2
 267    CALL       nl_set_e_we( 1, e_we )
 268    CALL       nl_set_e_sn( 1, e_sn )
 269
 270    CALL       wrf_message ( program_name )
 271    CALL       wrf_debug ( 100 , 'nup_em: calling alloc_and_configure_domain coarse ' )
 272    CALL alloc_and_configure_domain ( domain_id  = 1 ,                  &
 273                                      grid       = head_grid ,          &
 274                                      parent     = null_domain ,        &
 275                                      kid        = -1                   )
 276
 277    parent_grid => head_grid
 278
 279    !  Set up time initializations.
 280
 281    CALL Setup_Timekeeping ( parent_grid )
 282
 283    CALL domain_clock_set( head_grid, &
 284                           time_step_seconds=model_config_rec%interval_seconds )
 285
 286    CALL model_to_grid_config_rec ( parent_grid%id , model_config_rec , config_flags )
 287    CALL set_scalar_indices_from_config ( parent_grid%id , idum1, idum2 )
 288
 289 !!!! set up the fine grid  (for nup_em, this is the grid we do input into)
 290
 291    CALL       wrf_message ( program_name )
 292    CALL       wrf_debug ( 100 , 'wrf: calling alloc_and_configure_domain fine ' )
 293    CALL alloc_and_configure_domain ( domain_id  = 2 ,                  &
 294                                      grid       = nested_grid ,        &
 295                                      parent     = parent_grid ,        &
 296                                      kid        = 1                   )
 297
 298 ! now that the nest is allocated, pinch off the extra two rows/columns of the parent
 299 ! note the IKJ assumption here.
 300    parent_grid%ed31 = parent_grid%ed31 - 2
 301    parent_grid%ed33 = parent_grid%ed33 - 2
 302    CALL       nl_set_e_we( 1, e_we-2 )
 303    CALL       nl_set_e_sn( 1, e_sn-2 )
 304
 305 write(0,*)'after alloc_and_configure_domain ',associated(nested_grid%intermediate_grid)
 306
 307    CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags )
 308    CALL set_scalar_indices_from_config ( nested_grid%id , idum1, idum2 )
 309
 310    !  Set up time initializations for the fine grid.
 311
 312    CALL Setup_Timekeeping ( nested_grid )
 313    !  Adjust the time step on the clock so that it's the same as the history interval
 314
 315    CALL WRFU_AlarmGet( nested_grid%alarms(HISTORY_ALARM), RingInterval=RingInterval )
 316    CALL WRFU_ClockSet( nested_grid%domain_clock, TimeStep=RingInterval, rc=rc )
 317    CALL WRFU_ClockSet( parent_grid%domain_clock, TimeStep=RingInterval, rc=rc )
 318
 319    !  Get and store the history interval from the fine grid; use for time loop
 320
 321
 322    !  Initialize the I/O for WRF.
 323
 324    CALL init_wrfio
 325
 326    !  Some of the configuration values may have been modified from the initial READ
 327    !  of the NAMELIST, so we re-broadcast the configuration records.
 328
 329 #ifdef DM_PARALLEL
 330    CALL get_config_as_buffer( configbuf, configbuflen, nbytes )
 331    CALL wrf_dm_bcast_bytes( configbuf, nbytes )
 332    CALL set_config_as_buffer( configbuf, configbuflen )
 333 #endif
 334
 335    !  Open the input data (wrfout_d01_xxxxxx) for reading.
 336    in_id = 0
 337    out_id = 0
 338    main_loop : DO WHILE ( domain_get_current_time(nested_grid) .LT. domain_get_stop_time(nested_grid) )
 339
 340       IF( WRFU_AlarmIsRinging( nested_grid%alarms( HISTORY_ALARM ), rc=rc ) ) THEN
 341         CALL domain_clock_get( nested_grid, current_timestr=timestr )
 342         newly_opened = .FALSE.
 343         IF ( in_id.EQ. 0 ) THEN
 344           CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags )
 345           CALL construct_filename2a ( fname , config_flags%history_outname , nested_grid%id , 2 , timestr )
 346           CALL open_r_dataset ( in_id, TRIM(fname), nested_grid ,  &
 347                                  config_flags , 'DATASET=HISTORY' , ierr )
 348           IF ( ierr .NE. 0 ) THEN
 349             WRITE(message,*)'Failed to open ',TRIM(fname),' for reading. '
 350             CALL wrf_message(message)
 351             EXIT main_loop
 352           ENDIF
 353
 354           CALL model_to_grid_config_rec ( parent_grid%id , model_config_rec , config_flags )
 355           CALL construct_filename2a ( fname , config_flags%history_outname , parent_grid%id , 2 , timestr )
 356           CALL open_w_dataset ( out_id, TRIM(fname), parent_grid ,  &
 357                                  config_flags , output_history, 'DATASET=HISTORY' , ierr )
 358           IF ( ierr .NE. 0 ) THEN
 359             WRITE(message,*)'Failed to open ',TRIM(fname),' for writing. '
 360             CALL wrf_message(message)
 361             EXIT main_loop
 362           ENDIF
 363           newly_opened = .TRUE.
 364         ENDIF
 365
 366         CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags )
 367         CALL input_history ( in_id, nested_grid , config_flags , ierr )
 368         IF ( ierr .NE. 0 ) THEN
 369           WRITE(message,*)'Unable to read time ',timestr
 370           CALL wrf_message(message)
 371           EXIT main_loop
 372         ENDIF
 373 !
 374         CALL nup ( nested_grid , parent_grid, in_id, out_id, newly_opened  )
 375 !
 376         CALL model_to_grid_config_rec ( parent_grid%id , model_config_rec , config_flags )
 377         CALL output_history ( out_id, parent_grid , config_flags , ierr )
 378         IF ( ierr .NE. 0 ) THEN
 379           WRITE(message,*)'Unable to write time ',timestr
 380           CALL wrf_message(message)
 381           EXIT main_loop
 382         ENDIF
 383
 384         nested_grid%nframes(history_only) = nested_grid%nframes(history_only) + 1
 385         IF ( nested_grid%nframes(history_only) >= config_flags%frames_per_outfile ) THEN
 386           CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags )
 387           CALL close_dataset ( in_id , config_flags , "DATASET=HISTORY" )
 388           CALL model_to_grid_config_rec ( parent_grid%id , model_config_rec , config_flags )
 389           CALL close_dataset ( out_id , config_flags , "DATASET=HISTORY" )
 390           in_id = 0
 391           out_id = 0
 392           nested_grid%nframes(history_only) = 0
 393         ENDIF
 394         CALL WRFU_AlarmRingerOff( nested_grid%alarms( HISTORY_ALARM ), rc=rc )
 395       ENDIF
 396       CALL domain_clockadvance( nested_grid )
 397       CALL domain_clockadvance( parent_grid )
 398    ENDDO main_loop
 399    CALL model_to_grid_config_rec ( parent_grid%id , model_config_rec , config_flags )
 400    CALL med_shutdown_io ( parent_grid , config_flags )
 401
 402    CALL wrf_debug ( 0 , 'nup_em: SUCCESS COMPLETE NUP_EM INIT' )
 403
 404 !  CALL wrf_shutdown
 405
 406    CALL WRFU_Finalize( rc=rc )
 407
 408 END PROGRAM nup_em
 409
 410 SUBROUTINE nup ( nested_grid, parent_grid , in_id, out_id, newly_opened )
 411   USE module_domain
 412   USE module_io_domain
 413   USE module_utility
 414   USE module_timing
 415   USE module_wrf_error
 416 !
 417   IMPLICIT NONE
 418
 419 ! Args
 420   TYPE(domain), POINTER :: parent_grid, nested_grid
 421   INTEGER, INTENT(IN) :: in_id, out_id    ! io descriptors
 422   LOGICAL, INTENT(IN) :: newly_opened     ! whether to add global metadata
 423 ! Local
 424   INTEGER :: julyr , julday , iswater , map_proj
 425   INTEGER :: icnt, ierr
 426   REAL    :: dt , new_bdy_frq
 427   REAL    :: gmt , cen_lat , cen_lon , dx , dy , truelat1 , truelat2 , moad_cen_lat , stand_lon
 428   REAL , DIMENSION(:,:,:) , ALLOCATABLE :: ubdy3dtemp1 , vbdy3dtemp1 , tbdy3dtemp1 , pbdy3dtemp1 , qbdy3dtemp1
 429   REAL , DIMENSION(:,:,:) , ALLOCATABLE :: mbdy2dtemp1
 430   REAL , DIMENSION(:,:,:) , ALLOCATABLE :: ubdy3dtemp2 , vbdy3dtemp2 , tbdy3dtemp2 , pbdy3dtemp2 , qbdy3dtemp2
 431   REAL , DIMENSION(:,:,:) , ALLOCATABLE :: mbdy2dtemp2
 432   INTEGER :: ids , ide , jds , jde , kds , kde
 433   INTEGER :: ims , ime , jms , jme , kms , kme
 434   INTEGER :: ips , ipe , jps , jpe , kps , kpe
 435   INTEGER :: its , ite , jts , jte , kts , kte
 436
 437   INTERFACE
 438      SUBROUTINE med_feedback_domain ( parent_grid , nested_grid )
 439         USE module_domain
 440         USE module_configure
 441         TYPE(domain), POINTER :: parent_grid , nested_grid
 442      END SUBROUTINE med_feedback_domain
 443      SUBROUTINE med_interp_domain ( parent_grid , nested_grid )
 444         USE module_domain
 445         USE module_configure
 446         TYPE(domain), POINTER :: parent_grid , nested_grid
 447      END SUBROUTINE med_interp_domain
 448   END INTERFACE
 449
 450   IF ( newly_opened ) THEN
 451     CALL wrf_get_dom_ti_integer ( in_id , 'MAP_PROJ' , map_proj , 1 , icnt , ierr )
 452     CALL wrf_get_dom_ti_real    ( in_id , 'DX'  , dx  , 1 , icnt , ierr )
 453     CALL wrf_get_dom_ti_real    ( in_id , 'DY'  , dy  , 1 , icnt , ierr )
 454     CALL wrf_get_dom_ti_real    ( in_id , 'CEN_LAT' , cen_lat , 1 , icnt , ierr )
 455     CALL wrf_get_dom_ti_real    ( in_id , 'CEN_LON' , cen_lon , 1 , icnt , ierr )
 456     CALL wrf_get_dom_ti_real    ( in_id , 'TRUELAT1' , truelat1 , 1 , icnt , ierr )
 457     CALL wrf_get_dom_ti_real    ( in_id , 'TRUELAT2' , truelat2 , 1 , icnt , ierr )
 458     CALL wrf_get_dom_ti_real    ( in_id , 'MOAD_CEN_LAT' , moad_cen_lat , 1 , icnt , ierr )
 459     CALL wrf_get_dom_ti_real    ( in_id , 'STAND_LON' , stand_lon , 1 , icnt , ierr )
 460 !     CALL wrf_get_dom_ti_real    ( in_id , 'GMT' , gmt , 1 , icnt , ierr )
 461 !     CALL wrf_get_dom_ti_integer ( in_id , 'JULYR' , julyr , 1 , icnt , ierr )
 462 !     CALL wrf_get_dom_ti_integer ( in_id , 'JULDAY' , julday , 1 , icnt , ierr )
 463     CALL wrf_get_dom_ti_integer ( in_id , 'ISWATER' , iswater , 1 , icnt , ierr )
 464   ENDIF
 465
 466   parent_grid%fnm    = nested_grid%fnm
 467   parent_grid%fnp    = nested_grid%fnp
 468   parent_grid%rdnw   = nested_grid%rdnw
 469   parent_grid%rdn    = nested_grid%rdn
 470   parent_grid%dnw    = nested_grid%dnw
 471   parent_grid%dn     = nested_grid%dn
 472   parent_grid%znu    = nested_grid%znu
 473   parent_grid%znw    = nested_grid%znw
 474
 475   parent_grid%zs        = nested_grid%zs
 476   parent_grid%dzs       = nested_grid%dzs
 477
 478   parent_grid%p_top     = nested_grid%p_top
 479   parent_grid%rdx       = nested_grid%rdx * 3.
 480   parent_grid%rdy       = nested_grid%rdy * 3.
 481   parent_grid%resm      = nested_grid%resm
 482   parent_grid%zetatop   = nested_grid%zetatop
 483   parent_grid%cf1       = nested_grid%cf1
 484   parent_grid%cf2       = nested_grid%cf2
 485   parent_grid%cf3       = nested_grid%cf3
 486
 487   parent_grid%cfn       = nested_grid%cfn
 488   parent_grid%cfn1      = nested_grid%cfn1
 489
 490 #ifdef WRF_CHEM
 491   parent_grid%chem_opt    = nested_grid%chem_opt
 492   parent_grid%chem_in_opt = nested_grid%chem_in_opt
 493 #endif
 494
 495 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 496
 497   !  Various sizes that we need to be concerned about.
 498
 499   ids = parent_grid%sd31
 500   ide = parent_grid%ed31
 501   kds = parent_grid%sd32
 502   kde = parent_grid%ed32
 503   jds = parent_grid%sd33
 504   jde = parent_grid%ed33
 505
 506   ims = parent_grid%sm31
 507   ime = parent_grid%em31
 508   kms = parent_grid%sm32
 509   kme = parent_grid%em32
 510   jms = parent_grid%sm33
 511   jme = parent_grid%em33
 512
 513   ips = parent_grid%sp31
 514   ipe = parent_grid%ep31
 515   kps = parent_grid%sp32
 516   kpe = parent_grid%ep32
 517   jps = parent_grid%sp33
 518   jpe = parent_grid%ep33
 519
 520   nested_grid%imask_nostag = 1
 521   nested_grid%imask_xstag = 1
 522   nested_grid%imask_ystag = 1
 523   nested_grid%imask_xystag = 1
 524
 525 ! Interpolate from nested_grid back onto parent_grid
 526   CALL med_feedback_domain ( parent_grid , nested_grid )
 527
 528   parent_grid%ht_int = parent_grid%ht
 529
 530 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 531
 532 #if 0
 533          CALL construct_filename2( si_inpname , 'wrf_real_input_em' , parent_grid%id , 2 , start_date_char )
 534          CALL       wrf_debug ( 100 , 'med_sidata_input: calling open_r_dataset for ' // TRIM(si_inpname) )
 535          CALL model_to_grid_config_rec ( parent_grid%id , model_config_rec , config_flags )
 536          CALL open_r_dataset ( idsi, TRIM(si_inpname) , parent_grid , config_flags , "DATASET=INPUT", ierr )
 537          IF ( ierr .NE. 0 ) THEN
 538             CALL wrf_error_fatal( 'real: error opening wrf_real_input_em for reading: ' // TRIM (si_inpname) )
 539          END IF
 540
 541          !  Input data.
 542
 543          CALL       wrf_debug ( 100 , 'nup_em: calling input_aux_model_input2' )
 544          CALL input_aux_model_input2 ( idsi , parent_grid , config_flags , ierr )
 545          parent_grid%ht_input = parent_grid%ht
 546
 547          !  Close this fine grid static input file.
 548
 549          CALL       wrf_debug ( 100 , 'nup_em: closing fine grid static input' )
 550          CALL close_dataset ( idsi , config_flags , "DATASET=INPUT" )
 551
 552          !  We need a parent grid landuse in the interpolation.  So we need to generate
 553          !  that field now.
 554
 555          IF      ( ( parent_grid%ivgtyp(ips,jps) .GT. 0 ) .AND. &
 556                    ( parent_grid%isltyp(ips,jps) .GT. 0 ) ) THEN
 557             DO j = jps, MIN(jde-1,jpe)
 558                DO i = ips, MIN(ide-1,ipe)
 559                   parent_grid% vegcat(i,j) = parent_grid%ivgtyp(i,j)
 560                   parent_grid%soilcat(i,j) = parent_grid%isltyp(i,j)
 561                END DO
 562             END DO
 563
 564          ELSE IF ( ( parent_grid% vegcat(ips,jps) .GT. 0.5 ) .AND. &
 565                    ( parent_grid%soilcat(ips,jps) .GT. 0.5 ) ) THEN
 566             DO j = jps, MIN(jde-1,jpe)
 567                DO i = ips, MIN(ide-1,ipe)
 568                   parent_grid%ivgtyp(i,j) = NINT(parent_grid% vegcat(i,j))
 569                   parent_grid%isltyp(i,j) = NINT(parent_grid%soilcat(i,j))
 570                END DO
 571             END DO
 572
 573          ELSE
 574             num_veg_cat      = SIZE ( parent_grid%landusef , DIM=2 )
 575             num_soil_top_cat = SIZE ( parent_grid%soilctop , DIM=2 )
 576             num_soil_bot_cat = SIZE ( parent_grid%soilcbot , DIM=2 )
 577
 578             CALL land_percentages (  parent_grid%xland , &
 579                                      parent_grid%landusef , parent_grid%soilctop , parent_grid%soilcbot , &
 580                                      parent_grid%isltyp , parent_grid%ivgtyp , &
 581                                      num_veg_cat , num_soil_top_cat , num_soil_bot_cat , &
 582                                      ids , ide , jds , jde , kds , kde , &
 583                                      ims , ime , jms , jme , kms , kme , &
 584                                      ips , ipe , jps , jpe , kps , kpe , &
 585                                      model_config_rec%iswater(parent_grid%id) )
 586
 587           END IF
 588
 589           DO j = jps, MIN(jde-1,jpe)
 590             DO i = ips, MIN(ide-1,ipe)
 591                parent_grid%lu_index(i,j) = parent_grid%ivgtyp(i,j)
 592             END DO
 593          END DO
 594
 595          CALL check_consistency ( parent_grid%ivgtyp , parent_grid%isltyp , parent_grid%landmask , &
 596                                   ids , ide , jds , jde , kds , kde , &
 597                                   ims , ime , jms , jme , kms , kme , &
 598                                   ips , ipe , jps , jpe , kps , kpe , &
 599                                   model_config_rec%iswater(parent_grid%id) )
 600
 601          CALL check_consistency2( parent_grid%ivgtyp , parent_grid%isltyp , parent_grid%landmask , &
 602                                   parent_grid%tmn , parent_grid%tsk , parent_grid%sst , parent_grid%xland , &
 603                                   parent_grid%tslb , parent_grid%smois , parent_grid%sh2o , &
 604                                   config_flags%num_soil_layers , parent_grid%id , &
 605                                   ids , ide , jds , jde , kds , kde , &
 606                                   ims , ime , jms , jme , kms , kme , &
 607                                   ips , ipe , jps , jpe , kps , kpe , &
 608                                   model_config_rec%iswater(parent_grid%id) )
 609
 610
 611 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 612
 613       !  We have 2 terrain elevations.  One is from input and the other is from the
 614       !  the horizontal interpolation.
 615
 616       parent_grid%ht_fine = parent_grid%ht_input
 617       parent_grid%ht      = parent_grid%ht_int
 618
 619       !  We have both the interpolated fields and the higher-resolution static fields.  From these
 620       !  the rebalancing is now done.  Note also that the field parent_grid%ht is now from the
 621       !  fine grid input file (after this call is completed).
 622
 623       CALL rebalance_driver ( parent_grid )
 624
 625       !  Different things happen during the different time loops:
 626       !      first loop - write wrfinput file, close data set, copy files to holder arrays
 627       !      middle loops - diff 3d/2d arrays, compute and output bc
 628       !      last loop - diff 3d/2d arrays, compute and output bc, write wrfbdy file, close wrfbdy file
 629
 630          !  Set the time info.
 631
 632          print *,'current_date = ',current_date
 633          CALL domain_clock_set( parent_grid, &
 634                                 current_timestr=current_date(1:19) )
 635 !
 636 ! SEP     Put in chemistry data
 637 !
 638 #ifdef WRF_CHEM
 639          IF( parent_grid%chem_opt .NE. 0 ) then
 640             IF( parent_grid%chem_in_opt .EQ. 0 ) then
 641              ! Read the chemistry data from a previous wrf forecast (wrfout file)
 642               ! Generate chemistry data from a idealized vertical profile
 643               message = 'STARTING WITH BACKGROUND CHEMISTRY '
 644               CALL  wrf_message ( message )
 645
 646               CALL input_chem_profile ( parent_grid )
 647
 648               message = 'READING BEIS3.11 EMISSIONS DATA'
 649               CALL  wrf_message ( message )
 650
 651               CALL med_read_wrf_chem_bioemiss ( parent_grid , config_flags)
 652             ELSE
 653               message = 'RUNNING WITHOUT CHEMISTRY INITIALIZATION'
 654               CALL  wrf_message ( message )
 655             ENDIF
 656          ENDIF
 657 #endif
 658
 659 #endif
 660
 661          !  Output the first time period of the data.
 662
 663   IF ( newly_opened ) THEN
 664     CALL wrf_put_dom_ti_integer ( out_id , 'MAP_PROJ' , map_proj , 1 , ierr )
 665 !     CALL wrf_put_dom_ti_real    ( out_id , 'DX'  , dx  , 1 , ierr )
 666 !     CALL wrf_put_dom_ti_real    ( out_id , 'DY'  , dy  , 1 , ierr )
 667     CALL wrf_put_dom_ti_real    ( out_id , 'CEN_LAT' , cen_lat , 1 , ierr )
 668     CALL wrf_put_dom_ti_real    ( out_id , 'CEN_LON' , cen_lon , 1 , ierr )
 669     CALL wrf_put_dom_ti_real    ( out_id , 'TRUELAT1' , truelat1 , 1 , ierr )
 670     CALL wrf_put_dom_ti_real    ( out_id , 'TRUELAT2' , truelat2 , 1 , ierr )
 671     CALL wrf_put_dom_ti_real    ( out_id , 'MOAD_CEN_LAT' , moad_cen_lat , 1 , ierr )
 672     CALL wrf_put_dom_ti_real    ( out_id , 'STAND_LON' , stand_lon , 1 , ierr )
 673     CALL wrf_put_dom_ti_integer ( out_id , 'ISWATER' , iswater , 1 , ierr )
 674
 675     CALL wrf_put_dom_ti_real    ( out_id , 'GMT' , gmt , 1 , ierr )
 676     CALL wrf_put_dom_ti_integer ( out_id , 'JULYR' , julyr , 1 , ierr )
 677     CALL wrf_put_dom_ti_integer ( out_id , 'JULDAY' , julday , 1 , ierr )
 678   ENDIF
 679
 680 END SUBROUTINE nup
 681
 682 SUBROUTINE land_percentages ( xland , &
 683                               landuse_frac , soil_top_cat , soil_bot_cat , &
 684                               isltyp , ivgtyp , &
 685                               num_veg_cat , num_soil_top_cat , num_soil_bot_cat , &
 686                               ids , ide , jds , jde , kds , kde , &
 687                               ims , ime , jms , jme , kms , kme , &
 688                               its , ite , jts , jte , kts , kte , &
 689                               iswater )
 690    USE module_soil_pre
 691
 692    IMPLICIT NONE
 693
 694    INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
 695                            ims , ime , jms , jme , kms , kme , &
 696                            its , ite , jts , jte , kts , kte , &
 697                            iswater
 698
 699    INTEGER , INTENT(IN) :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat
 700    REAL , DIMENSION(ims:ime,1:num_veg_cat,jms:jme) , INTENT(INOUT):: landuse_frac
 701    REAL , DIMENSION(ims:ime,1:num_soil_top_cat,jms:jme) , INTENT(IN):: soil_top_cat
 702    REAL , DIMENSION(ims:ime,1:num_soil_bot_cat,jms:jme) , INTENT(IN):: soil_bot_cat
 703    INTEGER , DIMENSION(ims:ime,jms:jme), INTENT(OUT) :: isltyp , ivgtyp
 704    REAL , DIMENSION(ims:ime,jms:jme) , INTENT(OUT) :: xland
 705
 706    CALL process_percent_cat_new ( xland , &
 707                                   landuse_frac , soil_top_cat , soil_bot_cat , &
 708                                   isltyp , ivgtyp , &
 709                                   num_veg_cat , num_soil_top_cat , num_soil_bot_cat , &
 710                                   ids , ide , jds , jde , kds , kde , &
 711                                   ims , ime , jms , jme , kms , kme , &
 712                                   its , ite , jts , jte , kts , kte , &
 713                                   iswater )
 714
 715 END SUBROUTINE land_percentages
 716
 717 SUBROUTINE check_consistency ( ivgtyp , isltyp , landmask , &
 718                                   ids , ide , jds , jde , kds , kde , &
 719                                   ims , ime , jms , jme , kms , kme , &
 720                                   its , ite , jts , jte , kts , kte , &
 721                                   iswater )
 722
 723    IMPLICIT NONE
 724
 725    INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
 726                            ims , ime , jms , jme , kms , kme , &
 727                            its , ite , jts , jte , kts , kte , &
 728                            iswater
 729    INTEGER , DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: isltyp , ivgtyp
 730    REAL    , DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: landmask
 731
 732    LOGICAL :: oops
 733    INTEGER :: oops_count , i , j
 734
 735    oops = .FALSE.
 736    oops_count = 0
 737
 738    DO j = jts, MIN(jde-1,jte)
 739       DO i = its, MIN(ide-1,ite)
 740          IF ( ( ( landmask(i,j) .LT. 0.5 ) .AND. ( ivgtyp(i,j) .NE. iswater ) ) .OR. &
 741               ( ( landmask(i,j) .GT. 0.5 ) .AND. ( ivgtyp(i,j) .EQ. iswater ) ) ) THEN
 742             print *,'mismatch in landmask and veg type'
 743             print *,'i,j=',i,j, '  landmask =',NINT(landmask(i,j)),'  ivgtyp=',ivgtyp(i,j)
 744             oops = .TRUE.
 745             oops_count = oops_count + 1
 746 landmask(i,j) = 0
 747 ivgtyp(i,j)=16
 748 isltyp(i,j)=14
 749          END IF
 750       END DO
 751    END DO
 752
 753    IF ( oops ) THEN
 754       CALL wrf_debug( 0, 'mismatch in check_consistency, turned to water points, be careful' )
 755    END IF
 756
 757 END SUBROUTINE check_consistency
 758
 759 SUBROUTINE check_consistency2( ivgtyp , isltyp , landmask , &
 760                                tmn , tsk , sst , xland , &
 761                                tslb , smois , sh2o , &
 762                                num_soil_layers , id , &
 763                                ids , ide , jds , jde , kds , kde , &
 764                                ims , ime , jms , jme , kms , kme , &
 765                                its , ite , jts , jte , kts , kte , &
 766                                iswater )
 767
 768    USE module_configure
 769    USE module_optional_input
 770
 771    INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
 772                            ims , ime , jms , jme , kms , kme , &
 773                            its , ite , jts , jte , kts , kte
 774    INTEGER , INTENT(IN) :: num_soil_layers , id
 775
 776    INTEGER , DIMENSION(ims:ime,jms:jme) :: ivgtyp , isltyp
 777    REAL    , DIMENSION(ims:ime,jms:jme) :: landmask , tmn , tsk , sst , xland
 778    REAL    , DIMENSION(ims:ime,num_soil_layers,jms:jme) :: tslb , smois , sh2o
 779
 780    INTEGER :: oops1 , oops2
 781    INTEGER :: i , j , k
 782
 783       fix_tsk_tmn : SELECT CASE ( model_config_rec%sf_surface_physics(id) )
 784
 785          CASE ( SLABSCHEME , LSMSCHEME , RUCLSMSCHEME )
 786             DO j = jts, MIN(jde-1,jte)
 787                DO i = its, MIN(ide-1,ite)
 788                   IF ( ( landmask(i,j) .LT. 0.5 ) .AND. ( flag_sst .EQ. 1 ) ) THEN
 789                      tmn(i,j) = sst(i,j)
 790                      tsk(i,j) = sst(i,j)
 791                   ELSE IF ( landmask(i,j) .LT. 0.5 ) THEN
 792                      tmn(i,j) = tsk(i,j)
 793                   END IF
 794                END DO
 795             END DO
 796       END SELECT fix_tsk_tmn
 797
 798       !  Is the TSK reasonable?
 799
 800       DO j = jts, MIN(jde-1,jte)
 801          DO i = its, MIN(ide-1,ite)
 802             IF ( tsk(i,j) .LT. 170 .or. tsk(i,j) .GT. 400. ) THEN
 803                print *,'error in the TSK'
 804                print *,'i,j=',i,j
 805                print *,'landmask=',landmask(i,j)
 806                print *,'tsk, sst, tmn=',tsk(i,j),sst(i,j),tmn(i,j)
 807                if(tmn(i,j).gt.170. .and. tmn(i,j).lt.400.)then
 808                   tsk(i,j)=tmn(i,j)
 809                else if(sst(i,j).gt.170. .and. sst(i,j).lt.400.)then
 810                   tsk(i,j)=sst(i,j)
 811                else
 812                   CALL wrf_error_fatal ( 'TSK unreasonable' )
 813                end if
 814             END IF
 815          END DO
 816       END DO
 817
 818       !  Is the TMN reasonable?
 819
 820       DO j = jts, MIN(jde-1,jte)
 821          DO i = its, MIN(ide-1,ite)
 822             IF ( ( ( tmn(i,j) .LT. 170. ) .OR. ( tmn(i,j) .GT. 400. ) ) .AND. ( landmask(i,j) .GT. 0.5 ) ) THEN
 823                   print *,'error in the TMN'
 824                   print *,'i,j=',i,j
 825                   print *,'landmask=',landmask(i,j)
 826                   print *,'tsk, sst, tmn=',tsk(i,j),sst(i,j),tmn(i,j)
 827                if(tsk(i,j).gt.170. .and. tsk(i,j).lt.400.)then
 828                   tmn(i,j)=tsk(i,j)
 829                else if(sst(i,j).gt.170. .and. sst(i,j).lt.400.)then
 830                   tmn(i,j)=sst(i,j)
 831                else
 832                   CALL wrf_error_fatal ( 'TMN unreasonable' )
 833                endif
 834             END IF
 835          END DO
 836       END DO
 837
 838       !  Is the TSLB reasonable?
 839
 840       DO j = jts, MIN(jde-1,jte)
 841          DO i = its, MIN(ide-1,ite)
 842             IF ( ( ( tslb(i,1,j) .LT. 170. ) .OR. ( tslb(i,1,j) .GT. 400. ) ) .AND. ( landmask(i,j) .GT. 0.5 ) ) THEN
 843                   print *,'error in the TSLB'
 844                   print *,'i,j=',i,j
 845                   print *,'landmask=',landmask(i,j)
 846                   print *,'tsk, sst, tmn=',tsk(i,j),sst(i,j),tmn(i,j)
 847                   print *,'tslb = ',tslb(i,:,j)
 848                   print *,'old smois = ',smois(i,:,j)
 849                   DO l = 1 , num_soil_layers
 850                      sh2o(i,l,j) = 0.0
 851                   END DO
 852                   DO l = 1 , num_soil_layers
 853                      smois(i,l,j) = 0.3
 854                   END DO
 855                   if(tsk(i,j).gt.170. .and. tsk(i,j).lt.400.)then
 856                      DO l = 1 , num_soil_layers
 857                         tslb(i,l,j)=tsk(i,j)
 858                      END DO
 859                   else if(sst(i,j).gt.170. .and. sst(i,j).lt.400.)then
 860                      DO l = 1 , num_soil_layers
 861                         tslb(i,l,j)=sst(i,j)
 862                      END DO
 863                   else if(tmn(i,j).gt.170. .and. tmn(i,j).lt.400.)then
 864                      DO l = 1 , num_soil_layers
 865                         tslb(i,l,j)=tmn(i,j)
 866                      END DO
 867                   else
 868                      CALL wrf_error_fatal ( 'TSLB unreasonable' )
 869                   endif
 870             END IF
 871          END DO
 872       END DO
 873
 874       !  Let us make sure (again) that the landmask and the veg/soil categories match.
 875
 876 oops1=0
 877 oops2=0
 878       DO j = jts, MIN(jde-1,jte)
 879          DO i = its, MIN(ide-1,ite)
 880             IF ( ( ( landmask(i,j) .LT. 0.5 ) .AND. ( ivgtyp(i,j) .NE. iswater .OR. isltyp(i,j) .NE. 14 ) ) .OR. &
 881                  ( ( landmask(i,j) .GT. 0.5 ) .AND. ( ivgtyp(i,j) .EQ. iswater .OR. isltyp(i,j) .EQ. 14 ) ) ) THEN
 882                IF ( tslb(i,1,j) .GT. 1. ) THEN
 883 oops1=oops1+1
 884                   ivgtyp(i,j) = 5
 885                   isltyp(i,j) = 8
 886                   landmask(i,j) = 1
 887                   xland(i,j) = 1
 888                ELSE IF ( sst(i,j) .GT. 1. ) THEN
 889 oops2=oops2+1
 890                   ivgtyp(i,j) = iswater
 891                   isltyp(i,j) = 14
 892                   landmask(i,j) = 0
 893                   xland(i,j) = 2
 894                ELSE
 895                   print *,'the landmask and soil/veg cats do not match'
 896                   print *,'i,j=',i,j
 897                   print *,'landmask=',landmask(i,j)
 898                   print *,'ivgtyp=',ivgtyp(i,j)
 899                   print *,'isltyp=',isltyp(i,j)
 900                   print *,'iswater=', iswater
 901                   print *,'tslb=',tslb(i,:,j)
 902                   print *,'sst=',sst(i,j)
 903                   CALL wrf_error_fatal ( 'mismatch_landmask_ivgtyp' )
 904                END IF
 905             END IF
 906          END DO
 907       END DO
 908 if (oops1.gt.0) then
 909 print *,'points artificially set to land : ',oops1
 910 endif
 911 if(oops2.gt.0) then
 912 print *,'points artificially set to water: ',oops2
 913 endif
 914
 915 END SUBROUTINE check_consistency2