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