wrfv2_fire/main/ndown_em.F

   1 !WRF:DRIVER_LAYER:MAIN
   2 !
   3
   4 PROGRAM ndown_em
   5
   6    USE module_machine
   7    USE module_domain, ONLY : domain
   8    USE module_initialize_real, ONLY : wrfu_initialize, rebalance_driver
   9    USE module_integrate
  10    USE module_driver_constants
  11    USE module_configure, ONLY : grid_config_rec_type, model_config_rec
  12    USE module_io_domain
  13    USE module_utility
  14
  15    USE module_timing
  16    USE module_wrf_error
  17 #ifdef DM_PARALLEL
  18    USE module_dm
  19 #endif
  20
  21 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  22 !new for bc
  23    USE module_bc
  24    USE module_big_step_utilities_em
  25    USE module_get_file_names
  26 #ifdef WRF_CHEM
  27 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  28 ! for chemistry
  29    USE module_input_chem_data
  30 !  USE module_input_chem_bioemiss
  31 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  32 #endif
  33
  34    IMPLICIT NONE
  35  ! interface
  36    INTERFACE
  37      ! mediation-supplied
  38      SUBROUTINE med_read_wrf_chem_bioemiss ( grid , config_flags)
  39        USE module_domain
  40        TYPE (domain) grid
  41        TYPE (grid_config_rec_type) config_flags
  42      END SUBROUTINE med_read_wrf_chem_bioemiss
  43
  44      SUBROUTINE init_domain_constants_em_ptr ( parent , nest )
  45        USE module_domain
  46        USE module_configure
  47        TYPE(domain), POINTER  :: parent , nest
  48      END SUBROUTINE init_domain_constants_em_ptr
  49
  50    END INTERFACE
  51
  52
  53
  54 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  55 !new for bc
  56    INTEGER :: ids , ide , jds , jde , kds , kde
  57    INTEGER :: ims , ime , jms , jme , kms , kme
  58    INTEGER :: ips , ipe , jps , jpe , kps , kpe
  59    INTEGER :: its , ite , jts , jte , kts , kte
  60    INTEGER :: nids, nide, njds, njde, nkds, nkde,    &
  61               nims, nime, njms, njme, nkms, nkme,    &
  62               nips, nipe, njps, njpe, nkps, nkpe
  63    INTEGER :: spec_bdy_width
  64    INTEGER :: i , j , k , nvchem
  65    INTEGER :: time_loop_max , time_loop
  66    INTEGER :: total_time_sec , file_counter
  67    INTEGER :: julyr , julday , iswater , map_proj
  68    INTEGER :: icnt
  69
  70    REAL    :: dt , new_bdy_frq
  71    REAL    :: gmt , cen_lat , cen_lon , dx , dy , truelat1 , truelat2 , moad_cen_lat , stand_lon
  72
  73    REAL , DIMENSION(:,:,:) , ALLOCATABLE :: ubdy3dtemp1 , vbdy3dtemp1 , tbdy3dtemp1 , pbdy3dtemp1 , qbdy3dtemp1
  74    REAL , DIMENSION(:,:,:) , ALLOCATABLE :: mbdy2dtemp1
  75    REAL , DIMENSION(:,:,:) , ALLOCATABLE :: ubdy3dtemp2 , vbdy3dtemp2 , tbdy3dtemp2 , pbdy3dtemp2 , qbdy3dtemp2
  76    REAL , DIMENSION(:,:,:) , ALLOCATABLE :: mbdy2dtemp2
  77    REAL , DIMENSION(:,:,:) , ALLOCATABLE :: cbdy3dtemp1 , cbdy3dtemp2
  78    REAL , DIMENSION(:,:,:,:) , ALLOCATABLE :: cbdy3dtemp0
  79
  80    CHARACTER(LEN=19) :: start_date_char , current_date_char , end_date_char
  81    CHARACTER(LEN=19) :: stopTimeStr
  82
  83 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  84
  85    INTEGER :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat
  86
  87    REAL    :: time
  88    INTEGER :: rc
  89
  90    INTEGER :: loop , levels_to_process
  91    INTEGER , PARAMETER :: max_sanity_file_loop = 100
  92
  93    TYPE (domain) , POINTER :: keep_grid, grid_ptr, null_domain, parent_grid , nested_grid
  94    TYPE (domain)           :: dummy
  95    TYPE (grid_config_rec_type)              :: config_flags
  96    INTEGER                 :: number_at_same_level
  97    INTEGER                 :: time_step_begin_restart
  98
  99    INTEGER :: max_dom , domain_id , fid , fido, fidb , oid , idum1 , idum2 , ierr
 100    INTEGER :: status_next_var
 101    INTEGER :: debug_level
 102    LOGICAL :: input_from_file , need_new_file
 103    CHARACTER (LEN=19) :: date_string
 104
 105 #ifdef DM_PARALLEL
 106    INTEGER                 :: nbytes
 107    INTEGER, PARAMETER      :: configbuflen = 4* CONFIG_BUF_LEN
 108    INTEGER                 :: configbuf( configbuflen )
 109    LOGICAL , EXTERNAL      :: wrf_dm_on_monitor
 110 #endif
 111
 112    INTEGER                 :: idsi
 113    CHARACTER (LEN=80)      :: inpname , outname , bdyname
 114    CHARACTER (LEN=80)      :: si_inpname
 115 character *19 :: temp19
 116 character *24 :: temp24 , temp24b
 117 character(len=24) :: start_date_hold
 118
 119    CHARACTER (LEN=80)      :: message
 120 integer :: ii
 121
 122 #include "version_decl"
 123
 124    !  Interface block for routine that passes pointers and needs to know that they
 125    !  are receiving pointers.
 126
 127    INTERFACE
 128
 129       SUBROUTINE med_interp_domain ( parent_grid , nested_grid )
 130          USE module_domain
 131          USE module_configure
 132          TYPE(domain), POINTER :: parent_grid , nested_grid
 133       END SUBROUTINE med_interp_domain
 134
 135       SUBROUTINE Setup_Timekeeping( parent_grid )
 136          USE module_domain
 137          TYPE(domain), POINTER :: parent_grid
 138       END SUBROUTINE Setup_Timekeeping
 139
 140    END INTERFACE
 141
 142    !  Define the name of this program (program_name defined in module_domain)
 143
 144    program_name = "NDOWN_EM " // TRIM(release_version) // " PREPROCESSOR"
 145
 146 #ifdef DM_PARALLEL
 147    CALL disable_quilting
 148 #endif
 149
 150    !  Initialize the modules used by the WRF system.  Many of the CALLs made from the
 151    !  init_modules routine are NO-OPs.  Typical initializations are: the size of a
 152    !  REAL, setting the file handles to a pre-use value, defining moisture and
 153    !  chemistry indices, etc.
 154
 155    CALL init_modules(1)   ! Phase 1 returns after MPI_INIT() (if it is called)
 156    CALL WRFU_Initialize( defaultCalendar=WRFU_CAL_GREGORIAN, rc=rc )
 157    CALL init_modules(2)   ! Phase 2 resumes after MPI_INIT() (if it is called)
 158
 159    !  Get the NAMELIST data.  This is handled in the initial_config routine.  All of the
 160    !  NAMELIST input variables are assigned to the model_config_rec structure.  Below,
 161    !  note for parallel processing, only the monitor processor handles the raw Fortran
 162    !  I/O, and then broadcasts the info to each of the other nodes.
 163
 164 #ifdef DM_PARALLEL
 165    IF ( wrf_dm_on_monitor() ) THEN
 166      CALL initial_config
 167    ENDIF
 168    CALL get_config_as_buffer( configbuf, configbuflen, nbytes )
 169    CALL wrf_dm_bcast_bytes( configbuf, nbytes )
 170    CALL set_config_as_buffer( configbuf, configbuflen )
 171    CALL wrf_dm_initialize
 172 #else
 173    CALL initial_config
 174 #endif
 175
 176    !  And here is an instance of using the information in the NAMELIST.
 177
 178    CALL nl_get_debug_level ( 1, debug_level )
 179    CALL set_wrf_debug_level ( debug_level )
 180
 181    !  Allocated and configure the mother domain.  Since we are in the nesting down
 182    !  mode, we know a) we got a nest, and b) we only got 1 nest.
 183
 184    NULLIFY( null_domain )
 185
 186    CALL       wrf_message ( program_name )
 187    CALL       wrf_debug ( 100 , 'ndown_em: calling alloc_and_configure_domain coarse ' )
 188    CALL alloc_and_configure_domain ( domain_id  = 1 ,                  &
 189                                      grid       = head_grid ,          &
 190                                      parent     = null_domain ,        &
 191                                      kid        = -1                   )
 192
 193    parent_grid => head_grid
 194
 195    !  Set up time initializations.
 196
 197    CALL Setup_Timekeeping ( parent_grid )
 198
 199    CALL domain_clock_set( head_grid, &
 200                           time_step_seconds=model_config_rec%interval_seconds )
 201    CALL       wrf_debug ( 100 , 'ndown_em: calling model_to_grid_config_rec ' )
 202    CALL model_to_grid_config_rec ( parent_grid%id , model_config_rec , config_flags )
 203    CALL       wrf_debug ( 100 , 'ndown_em: calling set_scalar_indices_from_config ' )
 204    CALL set_scalar_indices_from_config ( parent_grid%id , idum1, idum2 )
 205
 206    !  Initialize the I/O for WRF.
 207
 208    CALL       wrf_debug ( 100 , 'ndown_em: calling init_wrfio' )
 209    CALL init_wrfio
 210
 211    !  Some of the configuration values may have been modified from the initial READ
 212    !  of the NAMELIST, so we re-broadcast the configuration records.
 213
 214 #ifdef DM_PARALLEL
 215    CALL get_config_as_buffer( configbuf, configbuflen, nbytes )
 216    CALL wrf_dm_bcast_bytes( configbuf, nbytes )
 217    CALL set_config_as_buffer( configbuf, configbuflen )
 218 #endif
 219
 220    !  We need to current and starting dates for the output files.  The times need to be incremented
 221    !  so that the lateral BC files are not overwritten.
 222
 223 #ifdef PLANET
 224    WRITE ( start_date_char , FMT = '(I4.4,"-",I5.5,"_",I2.2,":",I2.2,":",I2.2)' ) &
 225            model_config_rec%start_year  (parent_grid%id) , &
 226            model_config_rec%start_day   (parent_grid%id) , &
 227            model_config_rec%start_hour  (parent_grid%id) , &
 228            model_config_rec%start_minute(parent_grid%id) , &
 229            model_config_rec%start_second(parent_grid%id)
 230
 231    WRITE (   end_date_char , FMT = '(I4.4,"-",I5.5,"_",I2.2,":",I2.2,":",I2.2)' ) &
 232            model_config_rec%  end_year  (parent_grid%id) , &
 233            model_config_rec%  end_day   (parent_grid%id) , &
 234            model_config_rec%  end_hour  (parent_grid%id) , &
 235            model_config_rec%  end_minute(parent_grid%id) , &
 236            model_config_rec%  end_second(parent_grid%id)
 237 #else
 238    WRITE ( start_date_char , FMT = '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) &
 239            model_config_rec%start_year  (parent_grid%id) , &
 240            model_config_rec%start_month (parent_grid%id) , &
 241            model_config_rec%start_day   (parent_grid%id) , &
 242            model_config_rec%start_hour  (parent_grid%id) , &
 243            model_config_rec%start_minute(parent_grid%id) , &
 244            model_config_rec%start_second(parent_grid%id)
 245
 246    WRITE (   end_date_char , FMT = '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) &
 247            model_config_rec%  end_year  (parent_grid%id) , &
 248            model_config_rec%  end_month (parent_grid%id) , &
 249            model_config_rec%  end_day   (parent_grid%id) , &
 250            model_config_rec%  end_hour  (parent_grid%id) , &
 251            model_config_rec%  end_minute(parent_grid%id) , &
 252            model_config_rec%  end_second(parent_grid%id)
 253 #endif
 254
 255    !  Override stop time with value computed above.
 256    CALL domain_clock_set( parent_grid, stop_timestr=end_date_char )
 257
 258    CALL geth_idts ( end_date_char , start_date_char , total_time_sec )
 259
 260    new_bdy_frq = model_config_rec%interval_seconds
 261    time_loop_max = total_time_sec / model_config_rec%interval_seconds + 1
 262
 263    start_date        = start_date_char // '.0000'
 264    current_date      = start_date_char // '.0000'
 265    start_date_hold   = start_date_char // '.0000'
 266    current_date_char = start_date_char
 267
 268    !  Get a list of available file names to try.  This fills up the eligible_file_name
 269    !  array with number_of_eligible_files entries.  This routine issues a nonstandard
 270    !  call (system).
 271
 272    file_counter = 1
 273    need_new_file = .FALSE.
 274    CALL unix_ls ( 'wrfout' , parent_grid%id )
 275
 276    !  Open the input data (wrfout_d01_xxxxxx) for reading.
 277
 278    CALL wrf_debug          ( 100 , 'ndown_em main: calling open_r_dataset for ' // TRIM(eligible_file_name(file_counter)) )
 279    CALL open_r_dataset     ( fid, TRIM(eligible_file_name(file_counter)) , head_grid , config_flags , "DATASET=AUXINPUT1", ierr )
 280    IF ( ierr .NE. 0 ) THEN
 281       WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'program ndown: error opening ',TRIM(eligible_file_name(file_counter)), &
 282                                                   ' for reading ierr=',ierr
 283       CALL WRF_ERROR_FATAL ( wrf_err_message )
 284    ENDIF
 285
 286    !  We know how many time periods to process, so we begin.
 287
 288    big_time_loop_thingy : DO time_loop = 1 , time_loop_max
 289
 290       !  Which date are we currently soliciting?
 291
 292       CALL geth_newdate ( date_string , start_date_char , ( time_loop - 1 ) * NINT ( new_bdy_frq) )
 293 print *,'-------->>>  Processing data: loop=',time_loop,'  date/time = ',date_string
 294       current_date_char = date_string
 295       current_date      = date_string // '.0000'
 296       start_date        = date_string // '.0000'
 297 print *,'loopmax = ', time_loop_max, '   ending date = ',end_date_char
 298       CALL domain_clock_set( parent_grid, &
 299                              current_timestr=current_date(1:19) )
 300
 301       !  Which times are in this file, and more importantly, are any of them the
 302       !  ones that we want?  We need to loop over times in each files, loop
 303       !  over files.
 304
 305       get_the_right_time : DO
 306
 307          CALL wrf_get_next_time ( fid , date_string , status_next_var )
 308 print *,'file date/time = ',date_string,'     desired date = ',current_date_char,'     status = ', status_next_var
 309
 310          IF      (  status_next_var .NE. 0 ) THEN
 311             CALL wrf_debug          ( 100 , 'ndown_em main: calling close_dataset  for ' // TRIM(eligible_file_name(file_counter)) )
 312             CALL close_dataset      ( fid , config_flags , "DATASET=INPUT" )
 313             file_counter = file_counter + 1
 314             IF ( file_counter .GT. number_of_eligible_files ) THEN
 315                WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'program ndown: opening too many files'
 316                CALL WRF_ERROR_FATAL ( wrf_err_message )
 317             END IF
 318             CALL wrf_debug      ( 100 , 'ndown_em main: calling open_r_dataset for ' // TRIM(eligible_file_name(file_counter)) )
 319             CALL open_r_dataset ( fid, TRIM(eligible_file_name(file_counter)) , head_grid , config_flags , "DATASET=INPUT", ierr )
 320             IF ( ierr .NE. 0 ) THEN
 321                WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'program ndown: error opening ',TRIM(eligible_file_name(file_counter)), &
 322                                                            ' for reading ierr=',ierr
 323                CALL WRF_ERROR_FATAL ( wrf_err_message )
 324             ENDIF
 325             CYCLE get_the_right_time
 326          ELSE IF ( TRIM(date_string) .LT. TRIM(current_date_char) ) THEN
 327             CYCLE get_the_right_time
 328          ELSE IF ( TRIM(date_string) .EQ. TRIM(current_date_char) ) THEN
 329             EXIT get_the_right_time
 330          ELSE IF ( TRIM(date_string) .GT. TRIM(current_date_char) ) THEN
 331             WRITE( wrf_err_message , FMT='(A,A,A,A,A)' ) 'Found ',TRIM(date_string),' before I found ',TRIM(current_date_char),'.'
 332             CALL WRF_ERROR_FATAL ( wrf_err_message )
 333          END IF
 334       END DO get_the_right_time
 335
 336       CALL wrf_debug          ( 100 , 'wrf: calling input_history' )
 337       CALL wrf_get_previous_time ( fid , date_string , status_next_var )
 338       CALL input_history      ( fid , head_grid , config_flags, ierr )
 339       CALL wrf_debug          ( 100 , 'wrf: back from input_history' )
 340
 341       !  Get the coarse grid info for later transfer to the fine grid domain.
 342
 343       CALL wrf_get_dom_ti_integer ( fid , 'MAP_PROJ' , map_proj , 1 , icnt , ierr )
 344       CALL wrf_get_dom_ti_real    ( fid , 'DX'  , dx  , 1 , icnt , ierr )
 345       CALL wrf_get_dom_ti_real    ( fid , 'DY'  , dy  , 1 , icnt , ierr )
 346       CALL wrf_get_dom_ti_real    ( fid , 'CEN_LAT' , cen_lat , 1 , icnt , ierr )
 347       CALL wrf_get_dom_ti_real    ( fid , 'CEN_LON' , cen_lon , 1 , icnt , ierr )
 348       CALL wrf_get_dom_ti_real    ( fid , 'TRUELAT1' , truelat1 , 1 , icnt , ierr )
 349       CALL wrf_get_dom_ti_real    ( fid , 'TRUELAT2' , truelat2 , 1 , icnt , ierr )
 350       CALL wrf_get_dom_ti_real    ( fid , 'MOAD_CEN_LAT' , moad_cen_lat , 1 , icnt , ierr )
 351       CALL wrf_get_dom_ti_real    ( fid , 'STAND_LON' , stand_lon , 1 , icnt , ierr )
 352 !     CALL wrf_get_dom_ti_real    ( fid , 'GMT' , gmt , 1 , icnt , ierr )
 353 !     CALL wrf_get_dom_ti_integer ( fid , 'JULYR' , julyr , 1 , icnt , ierr )
 354 !     CALL wrf_get_dom_ti_integer ( fid , 'JULDAY' , julday , 1 , icnt , ierr )
 355       CALL wrf_get_dom_ti_integer ( fid , 'ISWATER' , iswater , 1 , icnt , ierr )
 356
 357       !  First time in, do this: allocate sapce for the fine grid, get the config flags, open the
 358       !  wrfinput and wrfbdy files.  This COULD be done outside the time loop, I think, so check it
 359       !  out and move it up if you can.
 360
 361       IF ( time_loop .EQ. 1 ) THEN
 362
 363          CALL       wrf_message ( program_name )
 364          CALL       wrf_debug ( 100 , 'wrf: calling alloc_and_configure_domain fine ' )
 365          CALL alloc_and_configure_domain ( domain_id  = 2 ,                  &
 366                                            grid       = nested_grid ,        &
 367                                            parent     = parent_grid ,        &
 368                                            kid        = 1                   )
 369
 370          CALL       wrf_debug ( 100 , 'wrf: calling model_to_grid_config_rec ' )
 371          CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags )
 372          CALL       wrf_debug ( 100 , 'wrf: calling set_scalar_indices_from_config ' )
 373          CALL set_scalar_indices_from_config ( nested_grid%id , idum1, idum2 )
 374
 375          !  Set up time initializations for the fine grid.
 376
 377          CALL Setup_Timekeeping ( nested_grid )
 378          ! Strictly speaking, nest stop time should come from model_config_rec...
 379          CALL domain_clock_get( parent_grid, stop_timestr=stopTimeStr )
 380          CALL domain_clock_set( nested_grid,                        &
 381                                 current_timestr=current_date(1:19), &
 382                                 stop_timestr=stopTimeStr ,          &
 383                                 time_step_seconds=                  &
 384                                   model_config_rec%interval_seconds )
 385
 386          !  Generate an output file from this program, which will be an input file to WRF.
 387
 388          CALL nl_set_bdyfrq ( nested_grid%id , new_bdy_frq )
 389          config_flags%bdyfrq = new_bdy_frq
 390
 391 #ifdef WRF_CHEM
 392 nested_grid%chem_opt    = parent_grid%chem_opt
 393 nested_grid%chem_in_opt = parent_grid%chem_in_opt
 394 #endif
 395
 396          !  Initialize constants and 1d arrays in fine grid from the parent.
 397
 398          CALL init_domain_constants_em_ptr ( parent_grid , nested_grid )
 399
 400 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 401
 402          CALL wrf_debug          ( 100 , 'ndown_em main: calling open_w_dataset for wrfinput' )
 403          CALL construct_filename1( outname , 'wrfinput' , nested_grid%id , 2 )
 404          CALL open_w_dataset     ( fido, TRIM(outname) , nested_grid , config_flags , output_model_input , "DATASET=INPUT", ierr )
 405          IF ( ierr .NE. 0 ) THEN
 406             WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'program ndown: error opening ',TRIM(outname),' for reading ierr=',ierr
 407             CALL WRF_ERROR_FATAL ( wrf_err_message )
 408          ENDIF
 409
 410          !  Various sizes that we need to be concerned about.
 411
 412          ids = nested_grid%sd31
 413          ide = nested_grid%ed31
 414          kds = nested_grid%sd32
 415          kde = nested_grid%ed32
 416          jds = nested_grid%sd33
 417          jde = nested_grid%ed33
 418
 419          ims = nested_grid%sm31
 420          ime = nested_grid%em31
 421          kms = nested_grid%sm32
 422          kme = nested_grid%em32
 423          jms = nested_grid%sm33
 424          jme = nested_grid%em33
 425
 426          ips = nested_grid%sp31
 427          ipe = nested_grid%ep31
 428          kps = nested_grid%sp32
 429          kpe = nested_grid%ep32
 430          jps = nested_grid%sp33
 431          jpe = nested_grid%ep33
 432
 433
 434          print *, ids , ide , jds , jde , kds , kde
 435          print *, ims , ime , jms , jme , kms , kme
 436          print *, ips , ipe , jps , jpe , kps , kpe
 437
 438          spec_bdy_width = model_config_rec%spec_bdy_width
 439          print *,'spec_bdy_width=',spec_bdy_width
 440
 441          !  This is the space needed to save the current 3d data for use in computing
 442          !  the lateral boundary tendencies.
 443
 444          ALLOCATE ( ubdy3dtemp1(ims:ime,kms:kme,jms:jme) )
 445          ALLOCATE ( vbdy3dtemp1(ims:ime,kms:kme,jms:jme) )
 446          ALLOCATE ( tbdy3dtemp1(ims:ime,kms:kme,jms:jme) )
 447          ALLOCATE ( pbdy3dtemp1(ims:ime,kms:kme,jms:jme) )
 448          ALLOCATE ( qbdy3dtemp1(ims:ime,kms:kme,jms:jme) )
 449          ALLOCATE ( mbdy2dtemp1(ims:ime,1:1,    jms:jme) )
 450          ALLOCATE ( ubdy3dtemp2(ims:ime,kms:kme,jms:jme) )
 451          ALLOCATE ( vbdy3dtemp2(ims:ime,kms:kme,jms:jme) )
 452          ALLOCATE ( tbdy3dtemp2(ims:ime,kms:kme,jms:jme) )
 453          ALLOCATE ( pbdy3dtemp2(ims:ime,kms:kme,jms:jme) )
 454          ALLOCATE ( qbdy3dtemp2(ims:ime,kms:kme,jms:jme) )
 455          ALLOCATE ( mbdy2dtemp2(ims:ime,1:1,    jms:jme) )
 456          ALLOCATE ( cbdy3dtemp0(ims:ime,kms:kme,jms:jme,1:num_chem) )
 457          ALLOCATE ( cbdy3dtemp1(ims:ime,kms:kme,jms:jme) )
 458          ALLOCATE ( cbdy3dtemp2(ims:ime,kms:kme,jms:jme) )
 459
 460       END IF
 461
 462       CALL domain_clock_set( nested_grid,                        &
 463                              current_timestr=current_date(1:19), &
 464                              time_step_seconds=                  &
 465                                model_config_rec%interval_seconds )
 466
 467       !  Do the horizontal interpolation.
 468
 469       nested_grid%imask_nostag = 1
 470       nested_grid%imask_xstag = 1
 471       nested_grid%imask_ystag = 1
 472       nested_grid%imask_xystag = 1
 473
 474       CALL med_interp_domain ( head_grid , nested_grid )
 475       nested_grid%ht_int = nested_grid%ht
 476
 477 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 478
 479       IF ( time_loop .EQ. 1 ) THEN
 480
 481          !  Dimension info for fine grid.
 482
 483          CALL get_ijk_from_grid (  nested_grid ,                   &
 484                                    nids, nide, njds, njde, nkds, nkde,    &
 485                                    nims, nime, njms, njme, nkms, nkme,    &
 486                                    nips, nipe, njps, njpe, nkps, nkpe    )
 487
 488          !  Store horizontally interpolated terrain in temp location
 489
 490          CALL  store_terrain ( nested_grid%ht_fine , nested_grid%ht , &
 491                                nids , nide , njds , njde , 1   , 1   , &
 492                                nims , nime , njms , njme , 1   , 1   , &
 493                                nips , nipe , njps , njpe , 1   , 1   )
 494
 495          !  Open the fine grid SI static file.
 496
 497          CALL construct_filename1( si_inpname , 'wrfndi' , nested_grid%id , 2 )
 498          CALL       wrf_debug ( 100 , 'med_sidata_input: calling open_r_dataset for ' // TRIM(si_inpname) )
 499          CALL open_r_dataset ( idsi, TRIM(si_inpname) , nested_grid , config_flags , "DATASET=INPUT", ierr )
 500          IF ( ierr .NE. 0 ) THEN
 501             CALL wrf_error_fatal( 'real: error opening FG input for reading: ' // TRIM (si_inpname) )
 502          END IF
 503
 504          !  Input data.
 505
 506          CALL       wrf_debug ( 100 , 'ndown_em: calling input_aux_model_input2' )
 507          CALL input_aux_model_input2 ( idsi , nested_grid , config_flags , ierr )
 508          nested_grid%ht_input = nested_grid%ht
 509
 510          !  Close this fine grid static input file.
 511
 512          CALL       wrf_debug ( 100 , 'ndown_em: closing fine grid static input' )
 513          CALL close_dataset ( idsi , config_flags , "DATASET=INPUT" )
 514
 515          !  Blend parent and nest field of terrain.
 516
 517          CALL blend_terrain ( nested_grid%ht_fine , nested_grid%ht , &
 518                                nids , nide , njds , njde , 1   , 1   , &
 519                                nims , nime , njms , njme , 1   , 1   , &
 520                                nips , nipe , njps , njpe , 1   , 1   )
 521
 522          nested_grid%ht_input = nested_grid%ht
 523          nested_grid%ht_int   = nested_grid%ht_fine
 524
 525          !  We need a fine grid landuse in the interpolation.  So we need to generate
 526          !  that field now.
 527
 528          IF      ( ( nested_grid%ivgtyp(ips,jps) .GT. 0 ) .AND. &
 529                    ( nested_grid%isltyp(ips,jps) .GT. 0 ) ) THEN
 530             DO j = jps, MIN(jde-1,jpe)
 531                DO i = ips, MIN(ide-1,ipe)
 532                   nested_grid% vegcat(i,j) = nested_grid%ivgtyp(i,j)
 533                   nested_grid%soilcat(i,j) = nested_grid%isltyp(i,j)
 534                END DO
 535             END DO
 536
 537          ELSE IF ( ( nested_grid% vegcat(ips,jps) .GT. 0.5 ) .AND. &
 538                    ( nested_grid%soilcat(ips,jps) .GT. 0.5 ) ) THEN
 539             DO j = jps, MIN(jde-1,jpe)
 540                DO i = ips, MIN(ide-1,ipe)
 541                   nested_grid%ivgtyp(i,j) = NINT(nested_grid% vegcat(i,j))
 542                   nested_grid%isltyp(i,j) = NINT(nested_grid%soilcat(i,j))
 543                END DO
 544             END DO
 545
 546          ELSE
 547             num_veg_cat      = SIZE ( nested_grid%landusef , DIM=2 )
 548             num_soil_top_cat = SIZE ( nested_grid%soilctop , DIM=2 )
 549             num_soil_bot_cat = SIZE ( nested_grid%soilcbot , DIM=2 )
 550
 551             CALL land_percentages (  nested_grid%xland , &
 552                                      nested_grid%landusef , nested_grid%soilctop , nested_grid%soilcbot , &
 553                                      nested_grid%isltyp , nested_grid%ivgtyp , &
 554                                      num_veg_cat , num_soil_top_cat , num_soil_bot_cat , &
 555                                      ids , ide , jds , jde , kds , kde , &
 556                                      ims , ime , jms , jme , kms , kme , &
 557                                      ips , ipe , jps , jpe , kps , kpe , &
 558                                      model_config_rec%iswater(nested_grid%id) )
 559
 560           END IF
 561
 562           DO j = jps, MIN(jde-1,jpe)
 563             DO i = ips, MIN(ide-1,ipe)
 564                nested_grid%lu_index(i,j) = nested_grid%ivgtyp(i,j)
 565             END DO
 566          END DO
 567
 568 #ifndef PLANET
 569          CALL check_consistency ( nested_grid%ivgtyp , nested_grid%isltyp , nested_grid%landmask , &
 570                                   ids , ide , jds , jde , kds , kde , &
 571                                   ims , ime , jms , jme , kms , kme , &
 572                                   ips , ipe , jps , jpe , kps , kpe , &
 573                                   model_config_rec%iswater(nested_grid%id) )
 574
 575          CALL check_consistency2( nested_grid%ivgtyp , nested_grid%isltyp , nested_grid%landmask , &
 576                                   nested_grid%tmn , nested_grid%tsk , nested_grid%sst , nested_grid%xland , &
 577                                   nested_grid%tslb , nested_grid%smois , nested_grid%sh2o , &
 578                                   config_flags%num_soil_layers , nested_grid%id , &
 579                                   ids , ide , jds , jde , kds , kde , &
 580                                   ims , ime , jms , jme , kms , kme , &
 581                                   ips , ipe , jps , jpe , kps , kpe , &
 582                                   model_config_rec%iswater(nested_grid%id) )
 583 #endif
 584
 585       END IF
 586
 587 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 588
 589       !  We have 2 terrain elevations.  One is from input and the other is from the
 590       !  the horizontal interpolation.
 591
 592       nested_grid%ht_fine = nested_grid%ht_input
 593       nested_grid%ht      = nested_grid%ht_int
 594
 595       !  We have both the interpolated fields and the higher-resolution static fields.  From these
 596       !  the rebalancing is now done.  Note also that the field nested_grid%ht is now from the
 597       !  fine grid input file (after this call is completed).
 598
 599       CALL rebalance_driver ( nested_grid )
 600
 601       !  Different things happen during the different time loops:
 602       !      first loop - write wrfinput file, close data set, copy files to holder arrays
 603       !      middle loops - diff 3d/2d arrays, compute and output bc
 604       !      last loop - diff 3d/2d arrays, compute and output bc, write wrfbdy file, close wrfbdy file
 605
 606       IF ( time_loop .EQ. 1 ) THEN
 607
 608          !  Set the time info.
 609
 610          print *,'current_date = ',current_date
 611          CALL domain_clock_set( nested_grid, &
 612                                 current_timestr=current_date(1:19) )
 613 #ifdef WRF_CHEM
 614 !
 615 ! SEP     Put in chemistry data
 616 !
 617          IF( nested_grid%chem_opt .NE. 0 ) then
 618 !           IF( nested_grid%chem_in_opt .EQ. 0 ) then
 619              ! Read the chemistry data from a previous wrf forecast (wrfout file)
 620               ! Generate chemistry data from a idealized vertical profile
 621 !             message = 'STARTING WITH BACKGROUND CHEMISTRY '
 622               CALL  wrf_message ( message )
 623
 624 !             CALL input_chem_profile ( nested_grid )
 625
 626               if( nested_grid%bio_emiss_opt .eq. 2 )then
 627                  message = 'READING BEIS3.11 EMISSIONS DATA'
 628                  CALL  wrf_message ( message )
 629                  CALL med_read_wrf_chem_bioemiss ( nested_grid , config_flags)
 630               else IF( nested_grid%bio_emiss_opt == 3 ) THEN !shc
 631                  message = 'READING MEGAN 2 EMISSIONS DATA'
 632                  CALL  wrf_message ( message )
 633                  CALL med_read_wrf_chem_bioemiss ( nested_grid , config_flags)
 634               endif
 635 !           ELSE
 636 !             message = 'RUNNING WITHOUT CHEMISTRY INITIALIZATION'
 637 !             CALL  wrf_message ( message )
 638 !           ENDIF
 639          ENDIF
 640 #endif
 641
 642          !  Output the first time period of the data.
 643
 644          CALL output_model_input ( fido , nested_grid , config_flags , ierr )
 645
 646          CALL wrf_put_dom_ti_integer ( fido , 'MAP_PROJ' , map_proj , 1 , ierr )
 647 !        CALL wrf_put_dom_ti_real    ( fido , 'DX'  , dx  , 1 , ierr )
 648 !        CALL wrf_put_dom_ti_real    ( fido , 'DY'  , dy  , 1 , ierr )
 649          CALL wrf_put_dom_ti_real    ( fido , 'CEN_LAT' , cen_lat , 1 , ierr )
 650          CALL wrf_put_dom_ti_real    ( fido , 'CEN_LON' , cen_lon , 1 , ierr )
 651          CALL wrf_put_dom_ti_real    ( fido , 'TRUELAT1' , truelat1 , 1 , ierr )
 652          CALL wrf_put_dom_ti_real    ( fido , 'TRUELAT2' , truelat2 , 1 , ierr )
 653          CALL wrf_put_dom_ti_real    ( fido , 'MOAD_CEN_LAT' , moad_cen_lat , 1 , ierr )
 654          CALL wrf_put_dom_ti_real    ( fido , 'STAND_LON' , stand_lon , 1 , ierr )
 655          CALL wrf_put_dom_ti_integer ( fido , 'ISWATER' , iswater , 1 , ierr )
 656
 657          !  These change if the initial time for the nest is not the same as the
 658          !  first time period in the WRF output file.
 659          !  Now that we know the starting date, we need to set the GMT, JULYR, and JULDAY
 660          !  values for the global attributes.  This call is based on the setting of the
 661          !  current_date string.
 662
 663          CALL geth_julgmt ( julyr , julday , gmt)
 664          CALL nl_set_julyr  ( nested_grid%id , julyr  )
 665          CALL nl_set_julday ( nested_grid%id , julday )
 666          CALL nl_set_gmt    ( nested_grid%id , gmt    )
 667          CALL wrf_put_dom_ti_real    ( fido , 'GMT' , gmt , 1 , ierr )
 668          CALL wrf_put_dom_ti_integer ( fido , 'JULYR' , julyr , 1 , ierr )
 669          CALL wrf_put_dom_ti_integer ( fido , 'JULDAY' , julday , 1 , ierr )
 670 print *,'current_date =',current_date
 671 print *,'julyr=',julyr
 672 print *,'julday=',julday
 673 print *,'gmt=',gmt
 674
 675          !  Close the input (wrfout_d01_000000, for example) file.  That's right, the
 676          !  input is an output file.  Who'd've thunk.
 677
 678          CALL close_dataset      ( fido , config_flags , "DATASET=INPUT" )
 679
 680          !  We need to save the 3d/2d data to compute a difference during the next loop.  Couple the
 681          !  3d fields with total mu (mub + mu_2) and the stagger-specific map scale factor.
 682
 683          ! u, theta, h, scalars coupled with my, v coupled with mx
 684          CALL couple ( nested_grid%mu_2 , nested_grid%mub , ubdy3dtemp1 , nested_grid%u_2                 , &
 685                        'u' , nested_grid%msfuy , &
 686                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
 687          CALL couple ( nested_grid%mu_2 , nested_grid%mub , vbdy3dtemp1 , nested_grid%v_2                 , &
 688                        'v' , nested_grid%msfvx , &
 689                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
 690          CALL couple ( nested_grid%mu_2 , nested_grid%mub , tbdy3dtemp1 , nested_grid%t_2                 , &
 691                        't' , nested_grid%msfty , &
 692                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
 693          CALL couple ( nested_grid%mu_2 , nested_grid%mub , pbdy3dtemp1 , nested_grid%ph_2                , &
 694                        'h' , nested_grid%msfty , &
 695                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
 696          CALL couple ( nested_grid%mu_2 , nested_grid%mub , qbdy3dtemp1 , nested_grid%moist(ims:ime,kms:kme,jms:jme,P_QV)    , &
 697                        't' , nested_grid%msfty , &
 698                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
 699
 700           DO j = jps , jpe
 701              DO i = ips , ipe
 702                 mbdy2dtemp1(i,1,j) = nested_grid%mu_2(i,j)
 703              END DO
 704           END DO
 705
 706          !  There are 2 components to the lateral boundaries.  First, there is the starting
 707          !  point of this time period - just the outer few rows and columns.
 708
 709          CALL stuff_bdy     ( ubdy3dtemp1 , nested_grid%u_bxs, nested_grid%u_bxe,                        &
 710                                             nested_grid%u_bys, nested_grid%u_bye,                        &
 711                                                                      'U' ,               spec_bdy_width      , &
 712                                                                            ids , ide , jds , jde , kds , kde , &
 713                                                                            ims , ime , jms , jme , kms , kme , &
 714                                                                            ips , ipe , jps , jpe , kps , kpe )
 715          CALL stuff_bdy     ( vbdy3dtemp1 , nested_grid%v_bxs, nested_grid%v_bxe,                        &
 716                                             nested_grid%v_bys, nested_grid%v_bye,                        &
 717                                                                      'V' ,               spec_bdy_width      , &
 718                                                                            ids , ide , jds , jde , kds , kde , &
 719                                                                            ims , ime , jms , jme , kms , kme , &
 720                                                                            ips , ipe , jps , jpe , kps , kpe )
 721          CALL stuff_bdy     ( tbdy3dtemp1 , nested_grid%t_bxs, nested_grid%t_bxe,                        &
 722                                             nested_grid%t_bys, nested_grid%t_bye,                        &
 723                                                                      'T' ,               spec_bdy_width      , &
 724                                                                            ids , ide , jds , jde , kds , kde , &
 725                                                                            ims , ime , jms , jme , kms , kme , &
 726                                                                            ips , ipe , jps , jpe , kps , kpe )
 727          CALL stuff_bdy     ( pbdy3dtemp1 , nested_grid%ph_bxs, nested_grid%ph_bxe,                      &
 728                                             nested_grid%ph_bys, nested_grid%ph_bye,                      &
 729                                                                      'W' ,               spec_bdy_width      , &
 730                                                                            ids , ide , jds , jde , kds , kde , &
 731                                                                            ims , ime , jms , jme , kms , kme , &
 732                                                                            ips , ipe , jps , jpe , kps , kpe )
 733          CALL stuff_bdy     ( qbdy3dtemp1 , nested_grid%moist_bxs(jms:jme,kms:kme,1:spec_bdy_width,P_QV), &
 734                                             nested_grid%moist_bxe(jms:jme,kms:kme,1:spec_bdy_width,P_QV), &
 735                                             nested_grid%moist_bys(ims:ime,kms:kme,1:spec_bdy_width,P_QV), &
 736                                             nested_grid%moist_bye(ims:ime,kms:kme,1:spec_bdy_width,P_QV), &
 737                                                                     'T' ,               spec_bdy_width      , &
 738                                                                            ids , ide , jds , jde , kds , kde , &
 739                                                                            ims , ime , jms , jme , kms , kme , &
 740                                                                            ips , ipe , jps , jpe , kps , kpe )
 741          CALL stuff_bdy     ( mbdy2dtemp1 , nested_grid%mu_bxs, nested_grid%mu_bxe,                      &
 742                                             nested_grid%mu_bys, nested_grid%mu_bye,                      &
 743                                                                      'M' ,               spec_bdy_width      , &
 744                                                                            ids , ide , jds , jde , 1 , 1 , &
 745                                                                            ims , ime , jms , jme , 1 , 1 , &
 746                                                                            ips , ipe , jps , jpe , 1 , 1 )
 747 #ifdef WRF_CHEM
 748          do nvchem=1,num_chem
 749 !        if(nvchem.eq.p_o3)then
 750 !          write(0,*)'fill ch_b',cbdy3dtemp1(5,1,5),nvchem
 751 !        endif
 752          cbdy3dtemp1(ips:ipe,kps:kpe,jps:jpe)=nested_grid%chem(ips:ipe,kps:kpe,jps:jpe,nvchem)
 753 !        if(nvchem.eq.p_o3)then
 754 !          write(0,*)'fill ch_b',cbdy3dtemp1(5,1,5)
 755 !        endif
 756          CALL stuff_bdy     ( cbdy3dtemp1 , nested_grid%chem_bxs(jms:jme,kms:kme,1:spec_bdy_width,nvchem),                                &
 757                                             nested_grid%chem_bxe(jms:jme,kms:kme,1:spec_bdy_width,nvchem),                                &
 758                                             nested_grid%chem_bys(ims:ime,kms:kme,1:spec_bdy_width,nvchem),                                &
 759                                             nested_grid%chem_bye(ims:ime,kms:kme,1:spec_bdy_width,nvchem),                                &
 760                                                                      'T' ,               spec_bdy_width      , &
 761                                                                            ids , ide , jds , jde , kds , kde , &
 762                                                                            ims , ime , jms , jme , kms , kme , &
 763                                                                            ips , ipe , jps , jpe , kps , kpe )
 764            cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem)=cbdy3dtemp1(ips:ipe,kps:kpe,jps:jpe)
 765 !        if(nvchem.eq.p_o3)then
 766 !          write(0,*)'filled ch_b',time_loop,cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem)
 767 !        endif
 768          enddo
 769 #endif
 770       ELSE IF ( ( time_loop .GT. 1 ) .AND. ( time_loop .LT. time_loop_max ) ) THEN
 771
 772          ! u, theta, h, scalars coupled with my, v coupled with mx
 773          CALL couple ( nested_grid%mu_2 , nested_grid%mub , ubdy3dtemp2 , nested_grid%u_2                 , &
 774                        'u' , nested_grid%msfuy , &
 775                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
 776          CALL couple ( nested_grid%mu_2 , nested_grid%mub , vbdy3dtemp2 , nested_grid%v_2                 , &
 777                        'v' , nested_grid%msfvx , &
 778                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
 779          CALL couple ( nested_grid%mu_2 , nested_grid%mub , tbdy3dtemp2 , nested_grid%t_2                 , &
 780                        't' , nested_grid%msfty , &
 781                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
 782          CALL couple ( nested_grid%mu_2 , nested_grid%mub , pbdy3dtemp2 , nested_grid%ph_2                , &
 783                        'h' , nested_grid%msfty , &
 784                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
 785          CALL couple ( nested_grid%mu_2 , nested_grid%mub , qbdy3dtemp2 , nested_grid%moist(ims:ime,kms:kme,jms:jme,P_QV)    , &
 786                        't' , nested_grid%msfty , &
 787                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
 788
 789           DO j = jps , jpe
 790              DO i = ips , ipe
 791                 mbdy2dtemp2(i,1,j) = nested_grid%mu_2(i,j)
 792              END DO
 793           END DO
 794
 795          !  During all of the loops after the first loop, we first compute the boundary
 796          !  tendencies with the current data values and the previously save information
 797          !  stored in the *bdy3dtemp1 arrays.
 798
 799          CALL stuff_bdytend ( ubdy3dtemp2 , ubdy3dtemp1 , new_bdy_frq ,                               &
 800                                             nested_grid%u_btxs, nested_grid%u_btxe   ,          &
 801                                             nested_grid%u_btys, nested_grid%u_btye   ,          &
 802                                                                   'U'  , &
 803                                                                                 spec_bdy_width      , &
 804                                                                   ids , ide , jds , jde , kds , kde , &
 805                                                                   ims , ime , jms , jme , kms , kme , &
 806                                                                   ips , ipe , jps , jpe , kps , kpe )
 807          CALL stuff_bdytend ( vbdy3dtemp2 , vbdy3dtemp1 , new_bdy_frq ,                               &
 808                                             nested_grid%v_btxs, nested_grid%v_btxe   ,          &
 809                                             nested_grid%v_btys, nested_grid%v_btye   ,          &
 810                                                                   'V'  , &
 811                                                                                 spec_bdy_width      , &
 812                                                                   ids , ide , jds , jde , kds , kde , &
 813                                                                   ims , ime , jms , jme , kms , kme , &
 814                                                                   ips , ipe , jps , jpe , kps , kpe )
 815          CALL stuff_bdytend ( tbdy3dtemp2 , tbdy3dtemp1 , new_bdy_frq ,                               &
 816                                             nested_grid%t_btxs, nested_grid%t_btxe   ,          &
 817                                             nested_grid%t_btys, nested_grid%t_btye   ,          &
 818                                                                   'T'  , &
 819                                                                                 spec_bdy_width      , &
 820                                                                   ids , ide , jds , jde , kds , kde , &
 821                                                                   ims , ime , jms , jme , kms , kme , &
 822                                                                   ips , ipe , jps , jpe , kps , kpe )
 823          CALL stuff_bdytend ( pbdy3dtemp2 , pbdy3dtemp1 , new_bdy_frq ,                               &
 824                                             nested_grid%ph_btxs, nested_grid%ph_btxe   ,        &
 825                                             nested_grid%ph_btys, nested_grid%ph_btye   ,        &
 826                                                                   'W' , &
 827                                                                                 spec_bdy_width      , &
 828                                                                   ids , ide , jds , jde , kds , kde , &
 829                                                                   ims , ime , jms , jme , kms , kme , &
 830                                                                   ips , ipe , jps , jpe , kps , kpe )
 831          CALL stuff_bdytend ( qbdy3dtemp2 , qbdy3dtemp1 , new_bdy_frq ,                               &
 832                                             nested_grid%moist_btxs(jms:jme,kms:kme,1:spec_bdy_width,P_QV), &
 833                                             nested_grid%moist_btxe(jms:jme,kms:kme,1:spec_bdy_width,P_QV), &
 834                                             nested_grid%moist_btys(ims:ime,kms:kme,1:spec_bdy_width,P_QV), &
 835                                             nested_grid%moist_btye(ims:ime,kms:kme,1:spec_bdy_width,P_QV), &
 836                                                                   'T' , &
 837                                                                                 spec_bdy_width      , &
 838                                                                   ids , ide , jds , jde , kds , kde , &
 839                                                                   ims , ime , jms , jme , kms , kme , &
 840                                                                   ips , ipe , jps , jpe , kps , kpe )
 841          CALL stuff_bdytend ( mbdy2dtemp2 , mbdy2dtemp1 , new_bdy_frq ,                               &
 842                                             nested_grid%mu_btxs, nested_grid%mu_btxe   ,        &
 843                                             nested_grid%mu_btys, nested_grid%mu_btye   ,        &
 844                                                                   'M' , &
 845                                                                                 spec_bdy_width      , &
 846                                                                   ids , ide , jds , jde , 1 , 1 , &
 847                                                                   ims , ime , jms , jme , 1 , 1 , &
 848                                                                   ips , ipe , jps , jpe , 1 , 1 )
 849 #ifdef WRF_CHEM
 850          do nvchem=1,num_chem
 851          cbdy3dtemp1(ips:ipe,kps:kpe,jps:jpe)=cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem)
 852          cbdy3dtemp2(ips:ipe,kps:kpe,jps:jpe)=nested_grid%chem(ips:ipe,kps:kpe,jps:jpe,nvchem)
 853 !        if(nvchem.eq.p_o3)then
 854 !          write(0,*)'fill 1ch_b2',time_loop,cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem),cbdy3dtemp2(ips,kps,jps)
 855 !        endif
 856          CALL stuff_bdytend ( cbdy3dtemp2 , cbdy3dtemp1 , new_bdy_frq ,  &
 857                                             nested_grid%chem_btxs(jms:jme,kms:kme,1:spec_bdy_width,nvchem), &
 858                                             nested_grid%chem_btxe(jms:jme,kms:kme,1:spec_bdy_width,nvchem), &
 859                                             nested_grid%chem_btys(ims:ime,kms:kme,1:spec_bdy_width,nvchem), &
 860                                             nested_grid%chem_btye(ims:ime,kms:kme,1:spec_bdy_width,nvchem), &
 861                                                                  'T' , &
 862                                                                                 spec_bdy_width      , &
 863                                                                   ids , ide , jds , jde , kds , kde , &
 864                                                                   ims , ime , jms , jme , kms , kme , &
 865                                                                   ips , ipe , jps , jpe , kps , kpe )
 866          cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem)=cbdy3dtemp2(ips:ipe,kps:kpe,jps:jpe)
 867 !        if(nvchem.eq.p_o3)then
 868 !          write(0,*)'fill 2ch_b2',cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem),cbdy3dtemp2(ips,kps,jps)
 869 !        endif
 870          enddo
 871 #endif
 872          IF ( time_loop .EQ. 2 ) THEN
 873
 874             !  Generate an output file from this program, which will be an input file to WRF.
 875
 876             CALL wrf_debug          ( 100 , 'ndown_em main: calling open_w_dataset for wrfbdy' )
 877             CALL construct_filename1( bdyname , 'wrfbdy' , nested_grid%id , 2 )
 878             CALL open_w_dataset     ( fidb, TRIM(bdyname) , nested_grid , config_flags , output_boundary , &
 879                                       "DATASET=BOUNDARY", ierr )
 880             IF ( ierr .NE. 0 ) THEN
 881                WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'program ndown: error opening ',TRIM(bdyname),' for reading ierr=',ierr
 882                CALL WRF_ERROR_FATAL ( wrf_err_message )
 883             ENDIF
 884
 885          END IF
 886
 887          !  Both pieces of the boundary data are now available to be written.
 888
 889       CALL domain_clock_set( nested_grid, &
 890                              current_timestr=current_date(1:19) )
 891       temp24= current_date
 892       temp24b=start_date_hold
 893       start_date = start_date_hold
 894       CALL geth_newdate ( temp19 , temp24b(1:19) , (time_loop-2) * model_config_rec%interval_seconds )
 895       current_date = temp19 //  '.0000'
 896       CALL geth_julgmt ( julyr , julday , gmt)
 897       CALL nl_set_julyr  ( nested_grid%id , julyr  )
 898       CALL nl_set_julday ( nested_grid%id , julday )
 899       CALL nl_set_gmt    ( nested_grid%id , gmt    )
 900       CALL wrf_put_dom_ti_real    ( fidb , 'GMT' , gmt , 1 , ierr )
 901       CALL wrf_put_dom_ti_integer ( fidb , 'JULYR' , julyr , 1 , ierr )
 902       CALL wrf_put_dom_ti_integer ( fidb , 'JULDAY' , julday , 1 , ierr )
 903       CALL domain_clock_set( nested_grid, &
 904                              current_timestr=current_date(1:19) )
 905 print *,'bdy time = ',time_loop-1,'  bdy date = ',current_date,' ',start_date
 906       CALL output_boundary ( fidb , nested_grid , config_flags , ierr )
 907       current_date = temp24
 908       start_date = temp24b
 909       CALL domain_clock_set( nested_grid, &
 910                              current_timestr=current_date(1:19) )
 911
 912          IF ( time_loop .EQ. 2 ) THEN
 913             CALL wrf_put_dom_ti_real    ( fidb , 'BDYFRQ' , new_bdy_frq , 1 , ierr )
 914          END IF
 915
 916          !  We need to save the 3d data to compute a difference during the next loop.  Couple the
 917          !  3d fields with total mu (mub + mu_2) and the stagger-specific map scale factor.
 918          !  We load up the boundary data again for use in the next loop.
 919
 920           DO j = jps , jpe
 921              DO k = kps , kpe
 922                 DO i = ips , ipe
 923                    ubdy3dtemp1(i,k,j) = ubdy3dtemp2(i,k,j)
 924                    vbdy3dtemp1(i,k,j) = vbdy3dtemp2(i,k,j)
 925                    tbdy3dtemp1(i,k,j) = tbdy3dtemp2(i,k,j)
 926                    pbdy3dtemp1(i,k,j) = pbdy3dtemp2(i,k,j)
 927                    qbdy3dtemp1(i,k,j) = qbdy3dtemp2(i,k,j)
 928                 END DO
 929              END DO
 930           END DO
 931
 932           DO j = jps , jpe
 933              DO i = ips , ipe
 934                 mbdy2dtemp1(i,1,j) = mbdy2dtemp2(i,1,j)
 935              END DO
 936           END DO
 937
 938          !  There are 2 components to the lateral boundaries.  First, there is the starting
 939          !  point of this time period - just the outer few rows and columns.
 940
 941          CALL stuff_bdy     ( ubdy3dtemp1 , &
 942                               nested_grid%u_bxs, nested_grid%u_bxe     ,                   &
 943                               nested_grid%u_bys, nested_grid%u_bye     ,                   &
 944                                                        'U' ,               spec_bdy_width      , &
 945                                                                            ids , ide , jds , jde , kds , kde , &
 946                                                                            ims , ime , jms , jme , kms , kme , &
 947                                                                            ips , ipe , jps , jpe , kps , kpe )
 948          CALL stuff_bdy     ( vbdy3dtemp1 , &
 949                               nested_grid%v_bxs, nested_grid%v_bxe     ,                   &
 950                               nested_grid%v_bys, nested_grid%v_bye     ,                   &
 951                                                        'V' ,               spec_bdy_width      , &
 952                                                                            ids , ide , jds , jde , kds , kde , &
 953                                                                            ims , ime , jms , jme , kms , kme , &
 954                                                                            ips , ipe , jps , jpe , kps , kpe )
 955          CALL stuff_bdy     ( tbdy3dtemp1 , &
 956                               nested_grid%t_bxs, nested_grid%t_bxe     ,                   &
 957                               nested_grid%t_bys, nested_grid%t_bye     ,                   &
 958                                                        'T' ,               spec_bdy_width      , &
 959                                                                            ids , ide , jds , jde , kds , kde , &
 960                                                                            ims , ime , jms , jme , kms , kme , &
 961                                                                            ips , ipe , jps , jpe , kps , kpe )
 962          CALL stuff_bdy     ( pbdy3dtemp1 , &
 963                               nested_grid%ph_bxs, nested_grid%ph_bxe     ,                   &
 964                               nested_grid%ph_bys, nested_grid%ph_bye     ,                   &
 965                                                        'W' ,               spec_bdy_width      , &
 966                                                                            ids , ide , jds , jde , kds , kde , &
 967                                                                            ims , ime , jms , jme , kms , kme , &
 968                                                                            ips , ipe , jps , jpe , kps , kpe )
 969          CALL stuff_bdy     ( qbdy3dtemp1 , &
 970                               nested_grid%moist_bxs(jms:jme,kms:kme,1:spec_bdy_width,P_QV), &
 971                               nested_grid%moist_bxe(jms:jme,kms:kme,1:spec_bdy_width,P_QV),     &
 972                               nested_grid%moist_bys(ims:ime,kms:kme,1:spec_bdy_width,P_QV), &
 973                               nested_grid%moist_bye(ims:ime,kms:kme,1:spec_bdy_width,P_QV),     &
 974                                                        'T' ,               spec_bdy_width      , &
 975                                                                            ids , ide , jds , jde , kds , kde , &
 976                                                                            ims , ime , jms , jme , kms , kme , &
 977                                                                            ips , ipe , jps , jpe , kps , kpe )
 978 #ifdef WRF_CHEM
 979          do nvchem=1,num_chem
 980          cbdy3dtemp1(ips:ipe,kps:kpe,jps:jpe)=cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem)
 981 !        if(nvchem.eq.p_o3)then
 982 !          write(0,*)'fill 2ch_b3',cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem)
 983 !        endif
 984          CALL stuff_bdy     ( cbdy3dtemp1 , &
 985                               nested_grid%chem_bxs(jms:jme,kms:kme,1:spec_bdy_width,nvchem), &
 986                               nested_grid%chem_bxe(jms:jme,kms:kme,1:spec_bdy_width,nvchem),     &
 987                               nested_grid%chem_bys(ims:ime,kms:kme,1:spec_bdy_width,nvchem), &
 988                               nested_grid%chem_bye(ims:ime,kms:kme,1:spec_bdy_width,nvchem),     &
 989                                                                     'T' ,               spec_bdy_width      , &
 990                                                                            ids , ide , jds , jde , kds , kde , &
 991                                                                            ims , ime , jms , jme , kms , kme , &
 992                                                                            ips , ipe , jps , jpe , kps , kpe )
 993 !          cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem)=cbdy3dtemp1(ips:ipe,kps:kpe,jps:jpe)
 994 !        if(nvchem.eq.p_o3)then
 995 !          write(0,*)'fill 2ch_b3',cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem)
 996 !        endif
 997          enddo
 998 #endif
 999          CALL stuff_bdy     ( mbdy2dtemp1 , &
1000                               nested_grid%mu_bxs, nested_grid%mu_bxe    ,  &
1001                               nested_grid%mu_bys, nested_grid%mu_bye    ,  &
1002                                                                      'M' ,               spec_bdy_width      , &
1003                                                                            ids , ide , jds , jde , 1 , 1 , &
1004                                                                            ims , ime , jms , jme , 1 , 1 , &
1005                                                                            ips , ipe , jps , jpe , 1 , 1 )
1006
1007       ELSE IF ( time_loop .EQ. time_loop_max ) THEN
1008
1009          ! u, theta, h, scalars coupled with my, v coupled with mx
1010          CALL couple ( nested_grid%mu_2 , nested_grid%mub , ubdy3dtemp2 , nested_grid%u_2                 , &
1011                        'u' , nested_grid%msfuy , &
1012                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
1013          CALL couple ( nested_grid%mu_2 , nested_grid%mub , vbdy3dtemp2 , nested_grid%v_2                 , &
1014                        'v' , nested_grid%msfvx , &
1015                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
1016          CALL couple ( nested_grid%mu_2 , nested_grid%mub , tbdy3dtemp2 , nested_grid%t_2                 , &
1017                        't' , nested_grid%msfty , &
1018                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
1019          CALL couple ( nested_grid%mu_2 , nested_grid%mub , pbdy3dtemp2 , nested_grid%ph_2                , &
1020                        'h' , nested_grid%msfty , &
1021                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
1022          CALL couple ( nested_grid%mu_2 , nested_grid%mub , qbdy3dtemp2 , nested_grid%moist(ims:ime,kms:kme,jms:jme,P_QV)    , &
1023                        't' , nested_grid%msfty , &
1024                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
1025          mbdy2dtemp2(:,1,:) = nested_grid%mu_2(:,:)
1026
1027          !  During all of the loops after the first loop, we first compute the boundary
1028          !  tendencies with the current data values and the previously save information
1029          !  stored in the *bdy3dtemp1 arrays.
1030 #ifdef WRF_CHEM
1031          do nvchem=1,num_chem
1032          cbdy3dtemp1(ips:ipe,kps:kpe,jps:jpe)=cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem)
1033          cbdy3dtemp2(ips:ipe,kps:kpe,jps:jpe)=nested_grid%chem(ips:ipe,kps:kpe,jps:jpe,nvchem)
1034 !        if(nvchem.eq.p_o3)then
1035 !          write(0,*)'fill 1ch_b4',cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem),cbdy3dtemp2(ips,kps,jps)
1036 !        endif
1037          CALL stuff_bdytend ( cbdy3dtemp2 , cbdy3dtemp1 , new_bdy_frq ,  &
1038                               nested_grid%chem_btxs(jms:jme,kms:kme,1:spec_bdy_width,nvchem),  &
1039                               nested_grid%chem_btxe(jms:jme,kms:kme,1:spec_bdy_width,nvchem), &
1040                               nested_grid%chem_btys(ims:ime,kms:kme,1:spec_bdy_width,nvchem),  &
1041                               nested_grid%chem_btye(ims:ime,kms:kme,1:spec_bdy_width,nvchem), &
1042                                                                   'T' , &
1043                                                                                 spec_bdy_width      , &
1044                                                                   ids , ide , jds , jde , kds , kde , &
1045                                                                   ims , ime , jms , jme , kms , kme , &
1046                                                                   ips , ipe , jps , jpe , kps , kpe )
1047          cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem)=cbdy3dtemp2(ips:ipe,kps:kpe,jps:jpe)
1048 !        if(nvchem.eq.p_o3)then
1049 !          write(0,*)'fill 2ch_b4',cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem),cbdy3dtemp2(ips,kps,jps)
1050 !        endif
1051          enddo
1052 #endif
1053
1054          CALL stuff_bdytend ( ubdy3dtemp2 , ubdy3dtemp1 , new_bdy_frq , &
1055                               nested_grid%u_btxs  , nested_grid%u_btxe , &
1056                               nested_grid%u_btys  , nested_grid%u_btye , &
1057                                                              'U'  , &
1058                                                                                 spec_bdy_width      , &
1059                                                                   ids , ide , jds , jde , kds , kde , &
1060                                                                   ims , ime , jms , jme , kms , kme , &
1061                                                                   ips , ipe , jps , jpe , kps , kpe )
1062          CALL stuff_bdytend ( vbdy3dtemp2 , vbdy3dtemp1 , new_bdy_frq , &
1063                               nested_grid%v_btxs  , nested_grid%v_btxe , &
1064                               nested_grid%v_btys  , nested_grid%v_btye , &
1065                                                              'V'  , &
1066                                                                                 spec_bdy_width      , &
1067                                                                   ids , ide , jds , jde , kds , kde , &
1068                                                                   ims , ime , jms , jme , kms , kme , &
1069                                                                   ips , ipe , jps , jpe , kps , kpe )
1070          CALL stuff_bdytend ( tbdy3dtemp2 , tbdy3dtemp1 , new_bdy_frq , &
1071                               nested_grid%t_btxs  , nested_grid%t_btxe , &
1072                               nested_grid%t_btys  , nested_grid%t_btye , &
1073                                                              'T'  , &
1074                                                                                 spec_bdy_width      , &
1075                                                                   ids , ide , jds , jde , kds , kde , &
1076                                                                   ims , ime , jms , jme , kms , kme , &
1077                                                                   ips , ipe , jps , jpe , kps , kpe )
1078          CALL stuff_bdytend ( pbdy3dtemp2 , pbdy3dtemp1 , new_bdy_frq , &
1079                               nested_grid%ph_btxs  , nested_grid%ph_btxe , &
1080                               nested_grid%ph_btys  , nested_grid%ph_btye , &
1081                                                              'W' , &
1082                                                                                 spec_bdy_width      , &
1083                                                                   ids , ide , jds , jde , kds , kde , &
1084                                                                   ims , ime , jms , jme , kms , kme , &
1085                                                                   ips , ipe , jps , jpe , kps , kpe )
1086          CALL stuff_bdytend ( qbdy3dtemp2 , qbdy3dtemp1 , new_bdy_frq , &
1087                               nested_grid%moist_btxs(jms:jme,kms:kme,1:spec_bdy_width,P_QV) , &
1088                               nested_grid%moist_btxe(jms:jme,kms:kme,1:spec_bdy_width,P_QV) , &
1089                               nested_grid%moist_btys(ims:ime,kms:kme,1:spec_bdy_width,P_QV) , &
1090                               nested_grid%moist_btye(ims:ime,kms:kme,1:spec_bdy_width,P_QV) , &
1091                                                              'T' , &
1092                                                                                 spec_bdy_width      , &
1093                                                                   ids , ide , jds , jde , kds , kde , &
1094                                                                   ims , ime , jms , jme , kms , kme , &
1095                                                                   ips , ipe , jps , jpe , kps , kpe )
1096          CALL stuff_bdytend ( mbdy2dtemp2 , mbdy2dtemp1 , new_bdy_frq , &
1097                               nested_grid%mu_btxs  , nested_grid%mu_btxe , &
1098                               nested_grid%mu_btys  , nested_grid%mu_btye , &
1099                                                              'M' , &
1100                                                                                 spec_bdy_width      , &
1101                                                                   ids , ide , jds , jde , 1 , 1 , &
1102                                                                   ims , ime , jms , jme , 1 , 1 , &
1103                                                                   ips , ipe , jps , jpe , 1 , 1 )
1104
1105          IF ( time_loop .EQ. 2 ) THEN
1106
1107             !  Generate an output file from this program, which will be an input file to WRF.
1108
1109             CALL wrf_debug          ( 100 , 'ndown_em main: calling open_w_dataset for wrfbdy' )
1110             CALL construct_filename1( bdyname , 'wrfbdy' , nested_grid%id , 2 )
1111             CALL open_w_dataset     ( fidb, TRIM(bdyname) , nested_grid , config_flags , output_boundary , &
1112                                       "DATASET=BOUNDARY", ierr )
1113             IF ( ierr .NE. 0 ) THEN
1114                WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'program ndown: error opening ',TRIM(bdyname),' for reading ierr=',ierr
1115                CALL WRF_ERROR_FATAL ( wrf_err_message )
1116             ENDIF
1117
1118          END IF
1119
1120          !  Both pieces of the boundary data are now available to be written.
1121
1122       CALL domain_clock_set( nested_grid, &
1123                              current_timestr=current_date(1:19) )
1124       temp24= current_date
1125       temp24b=start_date_hold
1126       start_date = start_date_hold
1127       CALL geth_newdate ( temp19 , temp24b(1:19) , (time_loop-2) * model_config_rec%interval_seconds )
1128       current_date = temp19 //  '.0000'
1129       CALL geth_julgmt ( julyr , julday , gmt)
1130       CALL nl_set_julyr  ( nested_grid%id , julyr  )
1131       CALL nl_set_julday ( nested_grid%id , julday )
1132       CALL nl_set_gmt    ( nested_grid%id , gmt    )
1133       CALL wrf_put_dom_ti_real    ( fidb , 'GMT' , gmt , 1 , ierr )
1134       CALL wrf_put_dom_ti_integer ( fidb , 'JULYR' , julyr , 1 , ierr )
1135       CALL wrf_put_dom_ti_integer ( fidb , 'JULDAY' , julday , 1 , ierr )
1136       CALL domain_clock_set( nested_grid, &
1137                              current_timestr=current_date(1:19) )
1138       CALL output_boundary ( fidb , nested_grid , config_flags , ierr )
1139       current_date = temp24
1140       start_date = temp24b
1141       CALL domain_clock_set( nested_grid, &
1142                              current_timestr=current_date(1:19) )
1143
1144          IF ( time_loop .EQ. 2 ) THEN
1145             CALL wrf_put_dom_ti_real    ( fidb , 'BDYFRQ' , new_bdy_frq , 1 , ierr )
1146          END IF
1147
1148          !  Since this is the last time through here, we need to close the boundary file.
1149
1150          CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags )
1151          CALL close_dataset ( fidb , config_flags , "DATASET=BOUNDARY" )
1152
1153
1154       END IF
1155
1156       !  Process which time now?
1157
1158    END DO big_time_loop_thingy
1159
1160    CALL model_to_grid_config_rec ( parent_grid%id , model_config_rec , config_flags )
1161    CALL med_shutdown_io ( parent_grid , config_flags )
1162
1163    CALL wrf_debug ( 0 , 'ndown_em: SUCCESS COMPLETE NDOWN_EM INIT' )
1164
1165    CALL wrf_shutdown
1166
1167    CALL WRFU_Finalize( rc=rc )
1168
1169 END PROGRAM ndown_em
1170
1171 SUBROUTINE land_percentages ( xland , &
1172                               landuse_frac , soil_top_cat , soil_bot_cat , &
1173                               isltyp , ivgtyp , &
1174                               num_veg_cat , num_soil_top_cat , num_soil_bot_cat , &
1175                               ids , ide , jds , jde , kds , kde , &
1176                               ims , ime , jms , jme , kms , kme , &
1177                               its , ite , jts , jte , kts , kte , &
1178                               iswater )
1179    USE module_soil_pre
1180
1181    IMPLICIT NONE
1182
1183    INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
1184                            ims , ime , jms , jme , kms , kme , &
1185                            its , ite , jts , jte , kts , kte , &
1186                            iswater
1187
1188    INTEGER , INTENT(IN) :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat
1189    REAL , DIMENSION(ims:ime,1:num_veg_cat,jms:jme) , INTENT(INOUT):: landuse_frac
1190    REAL , DIMENSION(ims:ime,1:num_soil_top_cat,jms:jme) , INTENT(IN):: soil_top_cat
1191    REAL , DIMENSION(ims:ime,1:num_soil_bot_cat,jms:jme) , INTENT(IN):: soil_bot_cat
1192    INTEGER , DIMENSION(ims:ime,jms:jme), INTENT(OUT) :: isltyp , ivgtyp
1193    REAL , DIMENSION(ims:ime,jms:jme) , INTENT(OUT) :: xland
1194
1195    CALL process_percent_cat_new ( xland , &
1196                                   landuse_frac , soil_top_cat , soil_bot_cat , &
1197                                   isltyp , ivgtyp , &
1198                                   num_veg_cat , num_soil_top_cat , num_soil_bot_cat , &
1199                                   ids , ide , jds , jde , kds , kde , &
1200                                   ims , ime , jms , jme , kms , kme , &
1201                                   its , ite , jts , jte , kts , kte , &
1202                                   iswater )
1203
1204 END SUBROUTINE land_percentages
1205
1206 SUBROUTINE check_consistency ( ivgtyp , isltyp , landmask , &
1207                                   ids , ide , jds , jde , kds , kde , &
1208                                   ims , ime , jms , jme , kms , kme , &
1209                                   its , ite , jts , jte , kts , kte , &
1210                                   iswater )
1211
1212    IMPLICIT NONE
1213
1214    INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
1215                            ims , ime , jms , jme , kms , kme , &
1216                            its , ite , jts , jte , kts , kte , &
1217                            iswater
1218    INTEGER , DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: isltyp , ivgtyp
1219    REAL    , DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: landmask
1220
1221    LOGICAL :: oops
1222    INTEGER :: oops_count , i , j
1223
1224    oops = .FALSE.
1225    oops_count = 0
1226
1227    DO j = jts, MIN(jde-1,jte)
1228       DO i = its, MIN(ide-1,ite)
1229          IF ( ( ( landmask(i,j) .LT. 0.5 ) .AND. ( ivgtyp(i,j) .NE. iswater ) ) .OR. &
1230               ( ( landmask(i,j) .GT. 0.5 ) .AND. ( ivgtyp(i,j) .EQ. iswater ) ) ) THEN
1231             print *,'mismatch in landmask and veg type'
1232             print *,'i,j=',i,j, '  landmask =',NINT(landmask(i,j)),'  ivgtyp=',ivgtyp(i,j)
1233             oops = .TRUE.
1234             oops_count = oops_count + 1
1235 landmask(i,j) = 0
1236 ivgtyp(i,j)=16
1237 isltyp(i,j)=14
1238          END IF
1239       END DO
1240    END DO
1241
1242    IF ( oops ) THEN
1243       CALL wrf_debug( 0, 'mismatch in check_consistency, turned to water points, be careful' )
1244    END IF
1245
1246 END SUBROUTINE check_consistency
1247
1248 SUBROUTINE check_consistency2( ivgtyp , isltyp , landmask , &
1249                                tmn , tsk , sst , xland , &
1250                                tslb , smois , sh2o , &
1251                                num_soil_layers , id , &
1252                                ids , ide , jds , jde , kds , kde , &
1253                                ims , ime , jms , jme , kms , kme , &
1254                                its , ite , jts , jte , kts , kte , &
1255                                iswater )
1256
1257    USE module_configure
1258    USE module_optional_input
1259
1260    INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
1261                            ims , ime , jms , jme , kms , kme , &
1262                            its , ite , jts , jte , kts , kte
1263    INTEGER , INTENT(IN) :: num_soil_layers , id
1264
1265    INTEGER , DIMENSION(ims:ime,jms:jme) :: ivgtyp , isltyp
1266    REAL    , DIMENSION(ims:ime,jms:jme) :: landmask , tmn , tsk , sst , xland
1267    REAL    , DIMENSION(ims:ime,num_soil_layers,jms:jme) :: tslb , smois , sh2o
1268
1269    INTEGER :: oops1 , oops2
1270    INTEGER :: i , j , k
1271
1272       fix_tsk_tmn : SELECT CASE ( model_config_rec%sf_surface_physics(id) )
1273
1274          CASE ( SLABSCHEME , LSMSCHEME , RUCLSMSCHEME )
1275             DO j = jts, MIN(jde-1,jte)
1276                DO i = its, MIN(ide-1,ite)
1277                   IF ( ( landmask(i,j) .LT. 0.5 ) .AND. ( flag_sst .EQ. 1 ) ) THEN
1278                      tmn(i,j) = sst(i,j)
1279                      tsk(i,j) = sst(i,j)
1280                   ELSE IF ( landmask(i,j) .LT. 0.5 ) THEN
1281                      tmn(i,j) = tsk(i,j)
1282                   END IF
1283                END DO
1284             END DO
1285       END SELECT fix_tsk_tmn
1286
1287       !  Is the TSK reasonable?
1288
1289       DO j = jts, MIN(jde-1,jte)
1290          DO i = its, MIN(ide-1,ite)
1291             IF ( tsk(i,j) .LT. 170 .or. tsk(i,j) .GT. 400. ) THEN
1292                print *,'error in the TSK'
1293                print *,'i,j=',i,j
1294                print *,'landmask=',landmask(i,j)
1295                print *,'tsk, sst, tmn=',tsk(i,j),sst(i,j),tmn(i,j)
1296                if(tmn(i,j).gt.170. .and. tmn(i,j).lt.400.)then
1297                   tsk(i,j)=tmn(i,j)
1298                else if(sst(i,j).gt.170. .and. sst(i,j).lt.400.)then
1299                   tsk(i,j)=sst(i,j)
1300                else
1301                   CALL wrf_error_fatal ( 'TSK unreasonable' )
1302                end if
1303             END IF
1304          END DO
1305       END DO
1306
1307       !  Is the TMN reasonable?
1308
1309       DO j = jts, MIN(jde-1,jte)
1310          DO i = its, MIN(ide-1,ite)
1311             IF ( ( ( tmn(i,j) .LT. 170. ) .OR. ( tmn(i,j) .GT. 400. ) ) .AND. ( landmask(i,j) .GT. 0.5 ) ) THEN
1312                   print *,'error in the TMN'
1313                   print *,'i,j=',i,j
1314                   print *,'landmask=',landmask(i,j)
1315                   print *,'tsk, sst, tmn=',tsk(i,j),sst(i,j),tmn(i,j)
1316                if(tsk(i,j).gt.170. .and. tsk(i,j).lt.400.)then
1317                   tmn(i,j)=tsk(i,j)
1318                else if(sst(i,j).gt.170. .and. sst(i,j).lt.400.)then
1319                   tmn(i,j)=sst(i,j)
1320                else
1321                   CALL wrf_error_fatal ( 'TMN unreasonable' )
1322                endif
1323             END IF
1324          END DO
1325       END DO
1326
1327       !  Is the TSLB reasonable?
1328
1329       DO j = jts, MIN(jde-1,jte)
1330          DO i = its, MIN(ide-1,ite)
1331             IF ( ( ( tslb(i,1,j) .LT. 170. ) .OR. ( tslb(i,1,j) .GT. 400. ) ) .AND. ( landmask(i,j) .GT. 0.5 ) ) THEN
1332                   print *,'error in the TSLB'
1333                   print *,'i,j=',i,j
1334                   print *,'landmask=',landmask(i,j)
1335                   print *,'tsk, sst, tmn=',tsk(i,j),sst(i,j),tmn(i,j)
1336                   print *,'tslb = ',tslb(i,:,j)
1337                   print *,'old smois = ',smois(i,:,j)
1338                   DO l = 1 , num_soil_layers
1339                      sh2o(i,l,j) = 0.0
1340                   END DO
1341                   DO l = 1 , num_soil_layers
1342                      smois(i,l,j) = 0.3
1343                   END DO
1344                   if(tsk(i,j).gt.170. .and. tsk(i,j).lt.400.)then
1345                      DO l = 1 , num_soil_layers
1346                         tslb(i,l,j)=tsk(i,j)
1347                      END DO
1348                   else if(sst(i,j).gt.170. .and. sst(i,j).lt.400.)then
1349                      DO l = 1 , num_soil_layers
1350                         tslb(i,l,j)=sst(i,j)
1351                      END DO
1352                   else if(tmn(i,j).gt.170. .and. tmn(i,j).lt.400.)then
1353                      DO l = 1 , num_soil_layers
1354                         tslb(i,l,j)=tmn(i,j)
1355                      END DO
1356                   else
1357                      CALL wrf_error_fatal ( 'TSLB unreasonable' )
1358                   endif
1359             END IF
1360          END DO
1361       END DO
1362
1363       !  Let us make sure (again) that the landmask and the veg/soil categories match.
1364
1365 oops1=0
1366 oops2=0
1367       DO j = jts, MIN(jde-1,jte)
1368          DO i = its, MIN(ide-1,ite)
1369             IF ( ( ( landmask(i,j) .LT. 0.5 ) .AND. ( ivgtyp(i,j) .NE. iswater .OR. isltyp(i,j) .NE. 14 ) ) .OR. &
1370                  ( ( landmask(i,j) .GT. 0.5 ) .AND. ( ivgtyp(i,j) .EQ. iswater .OR. isltyp(i,j) .EQ. 14 ) ) ) THEN
1371                IF ( tslb(i,1,j) .GT. 1. ) THEN
1372 oops1=oops1+1
1373                   ivgtyp(i,j) = 5
1374                   isltyp(i,j) = 8
1375                   landmask(i,j) = 1
1376                   xland(i,j) = 1
1377                ELSE IF ( sst(i,j) .GT. 1. ) THEN
1378 oops2=oops2+1
1379                   ivgtyp(i,j) = iswater
1380                   isltyp(i,j) = 14
1381                   landmask(i,j) = 0
1382                   xland(i,j) = 2
1383                ELSE
1384                   print *,'the landmask and soil/veg cats do not match'
1385                   print *,'i,j=',i,j
1386                   print *,'landmask=',landmask(i,j)
1387                   print *,'ivgtyp=',ivgtyp(i,j)
1388                   print *,'isltyp=',isltyp(i,j)
1389                   print *,'iswater=', iswater
1390                   print *,'tslb=',tslb(i,:,j)
1391                   print *,'sst=',sst(i,j)
1392                   CALL wrf_error_fatal ( 'mismatch_landmask_ivgtyp' )
1393                END IF
1394             END IF
1395          END DO
1396       END DO
1397 if (oops1.gt.0) then
1398 print *,'points artificially set to land : ',oops1
1399 endif
1400 if(oops2.gt.0) then
1401 print *,'points artificially set to water: ',oops2
1402 endif
1403
1404 END SUBROUTINE check_consistency2
1405
1406 SUBROUTINE init_domain_constants_em_ptr ( parent , nest )
1407    USE module_domain
1408    USE module_configure
1409    IMPLICIT NONE
1410    TYPE(domain), POINTER  :: parent , nest
1411    INTERFACE
1412    SUBROUTINE init_domain_constants_em ( parent , nest )
1413       USE module_domain
1414       USE module_configure
1415       TYPE(domain)  :: parent , nest
1416    END SUBROUTINE init_domain_constants_em
1417    END INTERFACE
1418    CALL init_domain_constants_em ( parent , nest )
1419 END SUBROUTINE init_domain_constants_em_ptr