wrfv2_fire/main/real_nmm.F

   1 !  Create an initial data set for the WRF model based on real data.  This
   2 !  program is specifically set up for the NMM core.
   3
   4 PROGRAM real_data
   5
   6    USE module_machine
   7    USE module_domain
   8    USE module_initialize_real
   9    USE module_io_domain
  10    USE module_driver_constants
  11    USE module_configure
  12    USE module_timing
  13 #ifdef WRF_CHEM
  14    USE module_input_chem_data
  15    USE module_input_chem_bioemiss
  16 #endif
  17    USE module_utility
  18 #ifdef DM_PARALLEL
  19    USE module_dm
  20 #endif
  21
  22    IMPLICIT NONE
  23
  24    REAL    :: time , bdyfrq
  25
  26    INTEGER :: loop , levels_to_process , debug_level
  27
  28
  29    TYPE(domain) , POINTER :: null_domain
  30    TYPE(domain) , POINTER :: grid
  31    TYPE (grid_config_rec_type)              :: config_flags
  32    INTEGER                :: number_at_same_level
  33
  34    INTEGER :: max_dom, domain_id
  35    INTEGER :: idum1, idum2
  36 #ifdef DM_PARALLEL
  37    INTEGER                 :: nbytes
  38 !   INTEGER, PARAMETER      :: configbuflen = 2*1024
  39    INTEGER, PARAMETER      :: configbuflen = 4*CONFIG_BUF_LEN
  40    INTEGER                 :: configbuf( configbuflen )
  41    LOGICAL , EXTERNAL      :: wrf_dm_on_monitor
  42 #endif
  43
  44    INTEGER :: ids , ide , jds , jde , kds , kde
  45    INTEGER :: ims , ime , jms , jme , kms , kme
  46    INTEGER :: ips , ipe , jps , jpe , kps , kpe
  47    INTEGER :: ijds , ijde , spec_bdy_width
  48    INTEGER :: i , j , k , idts
  49
  50 #ifdef DEREF_KLUDGE
  51 !  see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
  52    INTEGER     :: sm31 , em31 , sm32 , em32 , sm33 , em33
  53    INTEGER     :: sm31x, em31x, sm32x, em32x, sm33x, em33x
  54    INTEGER     :: sm31y, em31y, sm32y, em32y, sm33y, em33y
  55 #endif
  56
  57    CHARACTER (LEN=80)     :: message
  58
  59    INTEGER :: start_year , start_month , start_day
  60    INTEGER :: start_hour , start_minute , start_second
  61    INTEGER :: end_year ,   end_month ,   end_day ,   &
  62               end_hour ,   end_minute ,   end_second
  63    INTEGER :: interval_seconds , real_data_init_type
  64    INTEGER :: time_loop_max , time_loop, rc
  65    REAL    :: t1,t2
  66
  67 #include "version_decl"
  68
  69    INTERFACE
  70      SUBROUTINE Setup_Timekeeping( grid )
  71       USE module_domain
  72       TYPE(domain), POINTER :: grid
  73      END SUBROUTINE Setup_Timekeeping
  74    END INTERFACE
  75
  76    !  Define the name of this program (program_name defined in module_domain)
  77
  78    program_name = "REAL_NMM " // TRIM(release_version) // " PREPROCESSOR"
  79
  80 #ifdef DM_PARALLEL
  81    CALL disable_quilting
  82 #endif
  83
  84 !       CALL start()
  85
  86    !  Initialize the modules used by the WRF system.
  87    !  Many of the CALLs made from the
  88    !  init_modules routine are NO-OPs.  Typical initializations
  89    !  are: the size of a
  90    !  REAL, setting the file handles to a pre-use value, defining moisture and
  91    !  chemistry indices, etc.
  92
  93    CALL       wrf_debug ( 100 , 'real_nmm: calling init_modules ' )
  94
  95 !!!!   CALL init_modules
  96    CALL init_modules(1)   ! Phase 1 returns after MPI_INIT() (if it is called)
  97    CALL WRFU_Initialize( defaultCalendar=WRFU_CAL_GREGORIAN, rc=rc )
  98    CALL init_modules(2)   ! Phase 2 resumes after MPI_INIT() (if it is called)
  99
 100    !  The configuration switches mostly come from the NAMELIST input.
 101
 102 #ifdef DM_PARALLEL
 103    IF ( wrf_dm_on_monitor() ) THEN
 104       write(message,*) 'call initial_config'
 105       CALL wrf_message ( message )
 106       CALL initial_config
 107    ENDIF
 108    CALL get_config_as_buffer( configbuf, configbuflen, nbytes )
 109    CALL wrf_dm_bcast_bytes( configbuf, nbytes )
 110    CALL set_config_as_buffer( configbuf, configbuflen )
 111    CALL wrf_dm_initialize
 112 #else
 113    CALL initial_config
 114 #endif
 115
 116
 117    CALL nl_get_debug_level ( 1, debug_level )
 118    CALL set_wrf_debug_level ( debug_level )
 119
 120    CALL  wrf_message ( program_name )
 121
 122    !  Allocate the space for the mother of all domains.
 123
 124    NULLIFY( null_domain )
 125    CALL  wrf_debug ( 100 , 'real_nmm: calling alloc_and_configure_domain ' )
 126    CALL alloc_and_configure_domain ( domain_id  = 1           , &
 127                                      grid       = head_grid   , &
 128                                      parent     = null_domain , &
 129                                      kid        = -1            )
 130
 131    grid => head_grid
 132
 133 #include "deref_kludge.h"
 134    CALL Setup_Timekeeping ( grid )
 135    CALL domain_clock_set( grid, &
 136                           time_step_seconds=model_config_rec%interval_seconds )
 137    CALL wrf_debug ( 100 , 'real_nmm: calling set_scalar_indices_from_config ' )
 138    CALL set_scalar_indices_from_config ( grid%id , idum1, idum2 )
 139
 140    CALL     wrf_debug ( 100 , 'real_nmm: calling model_to_grid_config_rec ' )
 141
 142    CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags )
 143
 144    write(message,*) 'after model_to_grid_config_rec, e_we, e_sn are: ', &
 145                     config_flags%e_we, config_flags%e_sn
 146    CALL wrf_message(message)
 147
 148    !  Initialize the WRF IO: open files, init file handles, etc.
 149
 150    CALL       wrf_debug ( 100 , 'real_nmm: calling init_wrfio' )
 151    CALL init_wrfio
 152
 153 !  Some of the configuration values may have been modified from the initial READ
 154 !  of the NAMELIST, so we re-broadcast the configuration records.
 155
 156 #ifdef DM_PARALLEL
 157    CALL wrf_debug ( 100 , 'real_nmm: re-broadcast the configuration records' )
 158    CALL get_config_as_buffer( configbuf, configbuflen, nbytes )
 159    CALL wrf_dm_bcast_bytes( configbuf, nbytes )
 160    CALL set_config_as_buffer( configbuf, configbuflen )
 161 #endif
 162
 163    !   No looping in this layer.
 164
 165    CALL med_sidata_input ( grid , config_flags )
 166
 167    !  We are done.
 168
 169    CALL       wrf_debug (   0 , 'real_nmm: SUCCESS COMPLETE REAL_NMM INIT' )
 170
 171 #ifdef DM_PARALLEL
 172     CALL wrf_dm_shutdown
 173 #endif
 174
 175    CALL WRFU_Finalize( rc=rc )
 176
 177 END PROGRAM real_data
 178
 179 SUBROUTINE med_sidata_input ( grid , config_flags )
 180   ! Driver layer
 181    USE module_domain
 182    USE module_io_domain
 183   ! Model layer
 184    USE module_configure
 185    USE module_bc_time_utilities
 186    USE module_initialize_real
 187    USE module_optional_input
 188 #ifdef WRF_CHEM
 189    USE module_input_chem_data
 190    USE module_input_chem_bioemiss
 191 #endif
 192
 193    USE module_si_io_nmm
 194
 195    USE module_date_time
 196
 197    IMPLICIT NONE
 198
 199
 200   ! Interface
 201    INTERFACE
 202      SUBROUTINE start_domain ( grid , allowed_to_read )
 203        USE module_domain
 204        TYPE (domain) grid
 205        LOGICAL, INTENT(IN) :: allowed_to_read
 206      END SUBROUTINE start_domain
 207    END INTERFACE
 208
 209   ! Arguments
 210    TYPE(domain)                :: grid
 211    TYPE (grid_config_rec_type) :: config_flags
 212   ! Local
 213    INTEGER                :: time_step_begin_restart
 214    INTEGER                :: idsi , ierr , myproc
 215    CHARACTER (LEN=80)      :: si_inpname
 216    CHARACTER (LEN=132)     :: message
 217
 218    CHARACTER(LEN=19) :: start_date_char , end_date_char , &
 219                         current_date_char , next_date_char
 220
 221    INTEGER :: time_loop_max , loop
 222    INTEGER :: julyr , julday , LEN
 223
 224    INTEGER :: io_form_auxinput1
 225    INTEGER, EXTERNAL :: use_package
 226
 227    LOGICAL :: using_binary_wrfsi
 228
 229    REAL :: gmt
 230    REAL :: t1,t2
 231
 232    INTEGER :: numx_sm_levels_input,numx_st_levels_input
 233    REAL,DIMENSION(100) :: smx_levels_input,stx_levels_input
 234
 235
 236 #ifdef DEREF_KLUDGE
 237 !  see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
 238    INTEGER     :: sm31 , em31 , sm32 , em32 , sm33 , em33
 239    INTEGER     :: sm31x, em31x, sm32x, em32x, sm33x, em33x
 240    INTEGER     :: sm31y, em31y, sm32y, em32y, sm33y, em33y
 241 #endif
 242
 243 #include "deref_kludge.h"
 244
 245
 246    grid%input_from_file = .true.
 247    grid%input_from_file = .false.
 248
 249    CALL compute_si_start_and_end ( model_config_rec%start_year  (grid%id) , &
 250                                    model_config_rec%start_month (grid%id) , &
 251                                    model_config_rec%start_day   (grid%id) , &
 252                                    model_config_rec%start_hour  (grid%id) , &
 253                                    model_config_rec%start_minute(grid%id) , &
 254                                    model_config_rec%start_second(grid%id) , &
 255                                    model_config_rec%  end_year  (grid%id) , &
 256                                    model_config_rec%  end_month (grid%id) , &
 257                                    model_config_rec%  end_day   (grid%id) , &
 258                                    model_config_rec%  end_hour  (grid%id) , &
 259                                    model_config_rec%  end_minute(grid%id) , &
 260                                    model_config_rec%  end_second(grid%id) , &
 261                                    model_config_rec%interval_seconds      , &
 262                                    model_config_rec%real_data_init_type   , &
 263                                    start_date_char , end_date_char , time_loop_max )
 264
 265    !  Here we define the initial time to process, for later use by the code.
 266
 267    current_date_char = start_date_char
 268 !   start_date = start_date_char // '.0000'
 269    start_date = start_date_char
 270    current_date = start_date
 271
 272    CALL nl_set_bdyfrq ( grid%id , REAL(model_config_rec%interval_seconds) )
 273
 274    !  Loop over each time period to process.
 275
 276    write(message,*) 'time_loop_max: ', time_loop_max
 277    CALL wrf_message(message)
 278    DO loop = 1 , time_loop_max
 279
 280      internal_time_loop=loop
 281
 282       write(message,*) 'loop=', loop
 283       CALL wrf_message(message)
 284
 285       write(message,*) '-----------------------------------------------------------'
 286       CALL wrf_message(message)
 287
 288       write(message,*) ' '
 289       CALL wrf_message(message)
 290       write(message,'(A,A,A,I2,A,I2)') ' Current date being processed: ', &
 291         current_date, ', which is loop #',loop,' out of ',time_loop_max
 292       CALL wrf_message(message)
 293
 294       !  After current_date has been set, fill in the julgmt stuff.
 295
 296       CALL geth_julgmt ( config_flags%julyr , config_flags%julday , &
 297                                               config_flags%gmt )
 298
 299       !  Now that the specific Julian info is available,
 300       !  save these in the model config record.
 301
 302       CALL nl_set_gmt (grid%id, config_flags%gmt)
 303       CALL nl_set_julyr (grid%id, config_flags%julyr)
 304       CALL nl_set_julday (grid%id, config_flags%julday)
 305
 306       CALL nl_get_io_form_auxinput1( 1, io_form_auxinput1 )
 307       using_binary_wrfsi=.false.
 308
 309
 310       write(message,*) 'TRIM(config_flags%auxinput1_inname): ', TRIM(config_flags%auxinput1_inname)
 311       CALL wrf_message(message)
 312
 313       IF (config_flags%auxinput1_inname(1:10) .eq. 'real_input') THEN
 314          using_binary_wrfsi=.true.
 315       ENDIF
 316
 317       SELECT CASE ( use_package(io_form_auxinput1) )
 318 #ifdef NETCDF
 319       CASE ( IO_NETCDF   )
 320
 321       !  Open the wrfinput file.
 322
 323         current_date_char(11:11)='_'
 324
 325        WRITE ( wrf_err_message , FMT='(A,A)' )'med_sidata_input: calling open_r_dataset for ',TRIM(config_flags%auxinput1_inname)
 326        CALL wrf_debug ( 100 , wrf_err_message )
 327        IF ( config_flags%auxinput1_inname(1:8) .NE. 'wrf_real' ) THEN
 328           CALL construct_filename4a( si_inpname , config_flags%auxinput1_inname , grid%id , 2 , current_date_char , &
 329                                      config_flags%io_form_auxinput1 )
 330        ELSE
 331           CALL construct_filename2a( si_inpname , config_flags%auxinput1_inname , grid%id , 2 , current_date_char )
 332        END IF
 333        CALL open_r_dataset ( idsi, TRIM(si_inpname) , grid , config_flags , "DATASET=AUXINPUT1", ierr )
 334
 335        IF ( ierr .NE. 0 ) THEN
 336           CALL wrf_error_fatal( 'error opening ' // TRIM(si_inpname) // ' for input; bad date in namelist or file not in directory' )
 337        ENDIF
 338
 339       !  Input data.
 340
 341       CALL wrf_debug (100, 'med_sidata_input: call input_auxinput1_wrf')
 342
 343       CALL input_auxinput1 ( idsi, grid, config_flags, ierr )
 344
 345       !  Possible optional SI input.  This sets flags used by init_domain.
 346
 347       IF ( loop .EQ. 1 ) THEN
 348          CALL  wrf_debug (100, 'med_sidata_input: call init_module_optional_input' )
 349          CALL init_module_optional_input ( grid , config_flags )
 350       CALL wrf_debug ( 100 , 'med_sidata_input: calling optional_input' )
 351 !
 352       CALL optional_input ( grid , idsi , config_flags )
 353         write(0,*) 'maxval st_input(1) within real_nmm: ', maxval(st_input(:,1,:))
 354       END IF
 355 !
 356       CALL close_dataset ( idsi , config_flags , "DATASET=AUXINPUT1" )
 357
 358 #endif
 359 #ifdef INTIO
 360       CASE ( IO_INTIO )
 361
 362       !  Possible optional SI input.  This sets flags used by init_domain.
 363
 364       IF ( loop .EQ. 1 ) THEN
 365          CALL  wrf_debug (100, 'med_sidata_input: call init_module_optional_input' )
 366          CALL init_module_optional_input ( grid , config_flags )
 367       END IF
 368
 369       IF (using_binary_wrfsi) THEN
 370
 371         current_date_char(11:11)='_'
 372         CALL read_si ( grid, current_date_char )
 373         current_date_char(11:11)='T'
 374
 375       ELSE
 376
 377         write(message,*) 'binary WPS branch'
 378         CALL wrf_message(message)
 379         current_date_char(11:11)='_'
 380         CALL construct_filename4a( si_inpname , config_flags%auxinput1_inname , grid%id , 2 , current_date_char , &
 381                                      config_flags%io_form_auxinput1 )
 382         CALL read_wps ( grid, trim(si_inpname), current_date_char, config_flags%num_metgrid_levels )
 383 !!! bogus set some flags??
 384       flag_metgrid=1
 385       flag_soilhgt=1
 386
 387
 388           ENDIF
 389
 390 #endif
 391       CASE DEFAULT
 392         CALL wrf_error_fatal('real: not valid io_form_auxinput1')
 393       END SELECT
 394
 395       grid%islope=1
 396       grid%vegfra=grid%vegfrc
 397       grid%dfrlg=grid%dfl/9.81
 398
 399       grid%isurban=1
 400       grid%isoilwater=14
 401
 402       !  Initialize the mother domain for this time period with input data.
 403
 404       CALL wrf_debug ( 100 , 'med_sidata_input: calling init_domain' )
 405       grid%input_from_file = .true.
 406
 407       CALL init_domain ( grid )
 408
 409       CALL model_to_grid_config_rec ( grid%id, model_config_rec, config_flags )
 410
 411       !  Close this file that is output from the SI and input to this pre-proc.
 412
 413       CALL wrf_debug ( 100 , 'med_sidata_input: back from init_domain' )
 414
 415
 416 !!! not sure about this, but doesnt seem like needs to be called each time
 417       IF ( loop .EQ. 1 ) THEN
 418         CALL start_domain ( grid , .TRUE.)
 419       END IF
 420
 421 #ifdef WRF_CHEM
 422       IF ( loop == 1 ) THEN
 423 !        IF ( ( grid%chem_opt .EQ. RADM2     ) .OR. &
 424 !             ( grid%chem_opt .EQ. RADM2SORG ) .OR. &
 425 !             ( grid%chem_opt .EQ. RACM      ) .OR. &
 426 !             ( grid%chem_opt .EQ. RACMSORG  ) ) THEN
 427          IF( grid%chem_opt > 0 ) then
 428            ! Read the chemistry data from a previous wrf forecast (wrfout file)
 429            IF(grid%chem_in_opt == 1 ) THEN
 430               message = 'INITIALIZING CHEMISTRY WITH OLD SIMULATION'
 431               CALL  wrf_message ( message )
 432
 433               CALL input_ext_chem_file( grid )
 434
 435               IF(grid%bio_emiss_opt == BEIS311 ) THEN
 436                  message = 'READING BEIS3.11 EMISSIONS DATA'
 437                  CALL  wrf_message ( message )
 438                  CALL med_read_wrf_chem_bioemiss ( grid , config_flags)
 439               else IF(grid%bio_emiss_opt == 3 ) THEN !shc
 440                  message = 'READING MEGAN 2 EMISSIONS DATA'
 441                  CALL  wrf_message ( message )
 442                  CALL med_read_wrf_chem_bioemiss ( grid , config_flags)
 443               END IF
 444
 445            ELSEIF(grid%chem_in_opt == 0)then
 446               ! Generate chemistry data from a idealized vertical profile
 447               message = 'STARTING WITH BACKGROUND CHEMISTRY '
 448               CALL  wrf_message ( message )
 449
 450               write(message,*)' ETA1 '
 451               CALL  wrf_message ( message )
 452 !             write(message,*) grid%eta1
 453 !             CALL  wrf_message ( message )
 454
 455               CALL input_chem_profile ( grid )
 456
 457               IF(grid%bio_emiss_opt == BEIS311 ) THEN
 458                  message = 'READING BEIS3.11 EMISSIONS DATA'
 459                  CALL  wrf_message ( message )
 460                  CALL med_read_wrf_chem_bioemiss ( grid , config_flags)
 461               else IF(grid%bio_emiss_opt == 3 ) THEN !shc
 462                  message = 'READING MEGAN 2 EMISSIONS DATA'
 463                  CALL  wrf_message ( message )
 464                  CALL med_read_wrf_chem_bioemiss ( grid , config_flags)
 465               END IF
 466
 467            ELSE
 468              message = 'RUNNING WITHOUT CHEMISTRY INITIALIZATION'
 469              CALL  wrf_message ( message )
 470            ENDIF
 471          ENDIF
 472       ENDIF
 473 #endif
 474
 475       config_flags%isurban=1
 476       config_flags%isoilwater=14
 477
 478       CALL assemble_output ( grid , config_flags , loop , time_loop_max )
 479
 480       !  Here we define the next time that we are going to process.
 481
 482       CALL geth_newdate ( current_date_char , start_date_char , &
 483                           loop * model_config_rec%interval_seconds )
 484       current_date =  current_date_char // '.0000'
 485
 486       CALL domain_clock_set( grid, current_date(1:19) )
 487
 488       write(message,*) 'current_date= ', current_date
 489       CALL wrf_message(message)
 490
 491    END DO
 492 END SUBROUTINE med_sidata_input
 493
 494 SUBROUTINE compute_si_start_and_end (  &
 495           start_year, start_month, start_day, start_hour, &
 496           start_minute, start_second, &
 497           end_year ,   end_month ,   end_day ,   end_hour , &
 498           end_minute ,   end_second , &
 499           interval_seconds , real_data_init_type , &
 500           start_date_char , end_date_char , time_loop_max )
 501
 502    USE module_date_time
 503
 504    IMPLICIT NONE
 505
 506    INTEGER :: start_year , start_month , start_day , &
 507               start_hour , start_minute , start_second
 508    INTEGER ::   end_year ,   end_month ,   end_day , &
 509                 end_hour ,   end_minute ,   end_second
 510    INTEGER :: interval_seconds , real_data_init_type
 511    INTEGER :: time_loop_max , time_loop
 512
 513    CHARACTER(LEN=132) :: message
 514    CHARACTER(LEN=19)  :: current_date_char , start_date_char , &
 515                         end_date_char , next_date_char
 516
 517 !   WRITE ( start_date_char , FMT = &
 518 !         '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) &
 519 !         start_year,start_month,start_day,start_hour,start_minute,start_second
 520 !   WRITE (   end_date_char , FMT = &
 521 !         '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) &
 522 !          end_year,  end_month,  end_day,  end_hour,  end_minute,  end_second
 523
 524    WRITE ( start_date_char , FMT = &
 525          '(I4.4,"-",I2.2,"-",I2.2,"T",I2.2,":",I2.2,":",I2.2)' ) &
 526          start_year,start_month,start_day,start_hour,start_minute,start_second
 527    WRITE (   end_date_char , FMT = &
 528          '(I4.4,"-",I2.2,"-",I2.2,"T",I2.2,":",I2.2,":",I2.2)' ) &
 529           end_year,  end_month,  end_day,  end_hour,  end_minute,  end_second
 530
 531 !  start_date = start_date_char // '.0000'
 532
 533    !  Figure out our loop count for the processing times.
 534
 535    time_loop = 1
 536    PRINT '(A,I4,A,A,A)','Time period #',time_loop, &
 537                         ' to process = ',start_date_char,'.'
 538    current_date_char = start_date_char
 539    loop_count : DO
 540       CALL geth_newdate (next_date_char, current_date_char, interval_seconds )
 541       IF      ( next_date_char .LT. end_date_char ) THEN
 542          time_loop = time_loop + 1
 543          PRINT '(A,I4,A,A,A)','Time period #',time_loop,&
 544                               ' to process = ',next_date_char,'.'
 545          current_date_char = next_date_char
 546       ELSE IF ( next_date_char .EQ. end_date_char ) THEN
 547          time_loop = time_loop + 1
 548          PRINT '(A,I4,A,A,A)','Time period #',time_loop,&
 549                               ' to process = ',next_date_char,'.'
 550          PRINT '(A,I4,A)','Total analysis times to input = ',time_loop,'.'
 551          time_loop_max = time_loop
 552          EXIT loop_count
 553       ELSE IF ( next_date_char .GT. end_date_char ) THEN
 554          PRINT '(A,I4,A)','Total analysis times to input = ',time_loop,'.'
 555          time_loop_max = time_loop
 556          EXIT loop_count
 557       END IF
 558    END DO loop_count
 559         write(message,*) 'done in si_start_and_end'
 560         CALL wrf_message(message)
 561 END SUBROUTINE compute_si_start_and_end
 562
 563 SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max )
 564
 565 !!! replace with something?   USE module_big_step_utilities_em
 566
 567    USE module_domain
 568    USE module_io_domain
 569    USE module_configure
 570    USE module_date_time
 571    USE module_bc
 572    IMPLICIT NONE
 573
 574    TYPE(domain)                 :: grid
 575    TYPE (grid_config_rec_type)  :: config_flags
 576    INTEGER , INTENT(IN)         :: loop , time_loop_max
 577
 578    INTEGER :: ids , ide , jds , jde , kds , kde
 579    INTEGER :: ims , ime , jms , jme , kms , kme
 580    INTEGER :: ips , ipe , jps , jpe , kps , kpe
 581    INTEGER :: ijds , ijde , spec_bdy_width
 582    INTEGER :: inc_h,inc_v
 583    INTEGER :: i , j , k , idts
 584
 585    INTEGER :: id1 , interval_seconds , ierr, rc, sst_update
 586    INTEGER , SAVE :: id ,id4
 587    CHARACTER (LEN=80) :: inpname , bdyname
 588    CHARACTER(LEN= 4) :: loop_char
 589    CHARACTER(LEN=132) :: message
 590 character *19 :: temp19
 591 character *24 :: temp24 , temp24b
 592
 593    REAL, DIMENSION(:,:,:), ALLOCATABLE, SAVE :: ubdy3dtemp1 , vbdy3dtemp1 ,&
 594                                                 tbdy3dtemp1 , &
 595                                                 cwmbdy3dtemp1 , qbdy3dtemp1,&
 596                                                 q2bdy3dtemp1 , pdbdy2dtemp1
 597    REAL, DIMENSION(:,:,:), ALLOCATABLE, SAVE :: ubdy3dtemp2 , vbdy3dtemp2 , &
 598                                                 tbdy3dtemp2 , &
 599                                                 cwmbdy3dtemp2 , qbdy3dtemp2, &
 600                                                 q2bdy3dtemp2, pdbdy2dtemp2
 601    REAL :: t1,t2
 602
 603 #ifdef DEREF_KLUDGE
 604 !  see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
 605    INTEGER     :: sm31 , em31 , sm32 , em32 , sm33 , em33
 606    INTEGER     :: sm31x, em31x, sm32x, em32x, sm33x, em33x
 607    INTEGER     :: sm31y, em31y, sm32y, em32y, sm33y, em33y
 608 #endif
 609
 610 #include "deref_kludge.h"
 611
 612
 613    !  Various sizes that we need to be concerned about.
 614
 615    ids = grid%sd31
 616    ide = grid%ed31-1 ! 030730tst
 617    jds = grid%sd32
 618    jde = grid%ed32-1 ! 030730tst
 619    kds = grid%sd33
 620    kde = grid%ed33-1 ! 030730tst
 621
 622    ims = grid%sm31
 623    ime = grid%em31
 624    jms = grid%sm32
 625    jme = grid%em32
 626    kms = grid%sm33
 627    kme = grid%em33
 628
 629    ips = grid%sp31
 630    ipe = grid%ep31-1 ! 030730tst
 631    jps = grid%sp32
 632    jpe = grid%ep32-1 ! 030730tst
 633    kps = grid%sp33
 634    kpe = grid%ep33-1 ! 030730tst
 635
 636         if (IPE .ne. IDE) IPE=IPE+1
 637         if (JPE .ne. JDE) JPE=JPE+1
 638
 639         write(message,*) 'assemble output (ids,ide): ', ids,ide
 640         CALL wrf_message(message)
 641         write(message,*) 'assemble output (ims,ime): ', ims,ime
 642         CALL wrf_message(message)
 643         write(message,*) 'assemble output (ips,ipe): ', ips,ipe
 644         CALL wrf_message(message)
 645
 646         write(message,*) 'assemble output (jds,jde): ', jds,jde
 647         CALL wrf_message(message)
 648         write(message,*) 'assemble output (jms,jme): ', jms,jme
 649         CALL wrf_message(message)
 650         write(message,*) 'assemble output (jps,jpe): ', jps,jpe
 651         CALL wrf_message(message)
 652
 653         write(message,*) 'assemble output (kds,kde): ', kds,kde
 654         CALL wrf_message(message)
 655         write(message,*) 'assemble output (kms,kme): ', kms,kme
 656         CALL wrf_message(message)
 657         write(message,*) 'assemble output (kps,kpe): ', kps,kpe
 658         CALL wrf_message(message)
 659
 660    ijds = MIN ( ids , jds )
 661 !mptest030805   ijde = MAX ( ide , jde )
 662    ijde = MAX ( ide , jde ) + 1   ! to make stuff_bdy dimensions consistent with alloc
 663
 664    !  Boundary width, scalar value.
 665
 666    spec_bdy_width = model_config_rec%spec_bdy_width
 667    interval_seconds = model_config_rec%interval_seconds
 668    sst_update = model_config_rec%sst_update
 669
 670 !-----------------------------------------------------------------------
 671 !
 672    main_loop_test: IF ( loop .EQ. 1 ) THEN
 673 !
 674 !-----------------------------------------------------------------------
 675
 676       IF ( time_loop_max .NE. 1 ) THEN
 677          IF(sst_update .EQ. 1)THEN
 678            CALL construct_filename1( inpname , 'wrflowinp' , grid%id , 2 )
 679            CALL open_w_dataset ( id4, TRIM(inpname) , grid , config_flags , output_auxinput4 , "DATASET=AUXINPUT4", ierr )
 680            IF ( ierr .NE. 0 ) THEN
 681               CALL wrf_error_fatal( 'real: error opening wrflowinp for writing' )
 682            END IF
 683            CALL output_auxinput4 ( id4, grid , config_flags , ierr )
 684          END IF
 685       END IF
 686
 687
 688    !  This is the space needed to save the current 3d data for use in computing
 689    !  the lateral boundary tendencies.
 690
 691       ALLOCATE ( ubdy3dtemp1(ims:ime,jms:jme,kms:kme) )
 692       ALLOCATE ( vbdy3dtemp1(ims:ime,jms:jme,kms:kme) )
 693       ALLOCATE ( tbdy3dtemp1(ims:ime,jms:jme,kms:kme) )
 694       ALLOCATE ( qbdy3dtemp1(ims:ime,jms:jme,kms:kme) )
 695       ALLOCATE ( cwmbdy3dtemp1(ims:ime,jms:jme,kms:kme) )
 696       ALLOCATE ( q2bdy3dtemp1(ims:ime,jms:jme,kms:kme) )
 697       ALLOCATE ( pdbdy2dtemp1(ims:ime,jms:jme,1:1) )
 698
 699         ubdy3dtemp1=0.
 700         vbdy3dtemp1=0.
 701         tbdy3dtemp1=0.
 702         qbdy3dtemp1=0.
 703         cwmbdy3dtemp1=0.
 704         q2bdy3dtemp1=0.
 705         pdbdy2dtemp1=0.
 706
 707       ALLOCATE ( ubdy3dtemp2(ims:ime,jms:jme,kms:kme) )
 708       ALLOCATE ( vbdy3dtemp2(ims:ime,jms:jme,kms:kme) )
 709       ALLOCATE ( tbdy3dtemp2(ims:ime,jms:jme,kms:kme) )
 710       ALLOCATE ( qbdy3dtemp2(ims:ime,jms:jme,kms:kme) )
 711       ALLOCATE ( cwmbdy3dtemp2(ims:ime,jms:jme,kms:kme) )
 712       ALLOCATE ( q2bdy3dtemp2(ims:ime,jms:jme,kms:kme) )
 713       ALLOCATE ( pdbdy2dtemp2(ims:ime,jms:jme,1:1) )
 714
 715         ubdy3dtemp2=0.
 716         vbdy3dtemp2=0.
 717         tbdy3dtemp2=0.
 718         qbdy3dtemp2=0.
 719         cwmbdy3dtemp2=0.
 720         q2bdy3dtemp2=0.
 721         pdbdy2dtemp2=0.
 722
 723       !  Open the wrfinput file.  From this program, this is an *output* file.
 724
 725       CALL construct_filename1( inpname , 'wrfinput' , grid%id , 2 )
 726
 727       CALL open_w_dataset ( id1, TRIM(inpname) , grid , config_flags , &
 728                             output_input , "DATASET=INPUT", ierr )
 729
 730       IF ( ierr .NE. 0 ) THEN
 731       CALL wrf_error_fatal( 'real: error opening wrfinput for writing' )
 732       ENDIF
 733
 734 !     CALL calc_current_date ( grid%id , 0. )
 735 !      grid%write_metadata = .true.
 736
 737         write(message,*) 'making call to output_input'
 738         CALL wrf_message(message)
 739
 740         CALL output_input ( id1, grid , config_flags , ierr )
 741
 742 !***
 743 !***  CLOSE THE WRFINPUT DATASET
 744 !***
 745       CALL close_dataset ( id1 , config_flags , "DATASET=INPUT" )
 746
 747       !  We need to save the 3d data to compute a
 748       !  difference during the next loop.
 749
 750 !
 751 !-----------------------------------------------------------------------
 752 !***  SOUTHERN BOUNDARY
 753 !-----------------------------------------------------------------------
 754 !
 755
 756         IF(JPS==JDS)THEN
 757           J=1
 758           DO k = kps , MIN(kde,kpe)
 759           DO i = ips , MIN(ide,ipe)
 760             ubdy3dtemp1(i,j,k) = grid%u(i,j,k)
 761             vbdy3dtemp1(i,j,k) = grid%v(i,j,k)
 762             tbdy3dtemp1(i,j,k) = grid%t(i,j,k)
 763             qbdy3dtemp1(i,j,k) = grid%q(i,j,k)
 764             cwmbdy3dtemp1(i,j,k) = grid%cwm(i,j,k)
 765             q2bdy3dtemp1(i,j,k) = grid%q2(i,j,k)
 766           END DO
 767           END DO
 768
 769           DO i = ips , MIN(ide,ipe)
 770             pdbdy2dtemp1(i,j,1) = grid%pd(i,j)
 771           END DO
 772         ENDIF
 773
 774 !
 775 !-----------------------------------------------------------------------
 776 !***  NORTHERN BOUNDARY
 777 !-----------------------------------------------------------------------
 778 !
 779         IF(JPE==JDE)THEN
 780           J=MIN(JDE,JPE)
 781           DO k = kps , MIN(kde,kpe)
 782           DO i = ips , MIN(ide,ipe)
 783             ubdy3dtemp1(i,j,k) = grid%u(i,j,k)
 784             vbdy3dtemp1(i,j,k) = grid%v(i,j,k)
 785             tbdy3dtemp1(i,j,k) = grid%t(i,j,k)
 786             qbdy3dtemp1(i,j,k) = grid%q(i,j,k)
 787             cwmbdy3dtemp1(i,j,k) = grid%cwm(i,j,k)
 788             q2bdy3dtemp1(i,j,k) = grid%q2(i,j,k)
 789           END DO
 790           END DO
 791
 792           DO i = ips , MIN(ide,ipe)
 793             pdbdy2dtemp1(i,j,1) = grid%pd(i,j)
 794           END DO
 795         ENDIF
 796
 797 !
 798 !-----------------------------------------------------------------------
 799 !***  WESTERN BOUNDARY
 800 !-----------------------------------------------------------------------
 801 !
 802         write(message,*) 'western boundary, store winds over J: ', jps, min(jpe,jde)
 803         CALL wrf_message(message)
 804
 805         IF(IPS==IDS)THEN
 806           I=1
 807           DO k = kps , MIN(kde,kpe)
 808           inc_h=mod(jps+1,2)
 809           DO j = jps+inc_h, min(jde,jpe),2
 810
 811         if (J .ge. 3 .and. J .le. JDE-2 .and. mod(J,2) .eq. 1) then
 812             tbdy3dtemp1(i,j,k) = grid%t(i,j,k)
 813             qbdy3dtemp1(i,j,k) = grid%q(i,j,k)
 814             cwmbdy3dtemp1(i,j,k) = grid%cwm(i,j,k)
 815             q2bdy3dtemp1(i,j,k) = grid%q2(i,j,k)
 816       if(k==1)then
 817         write(message,*)' loop=',loop,' i=',i,' j=',j,' tbdy3dtemp1(i,j,k)=',tbdy3dtemp1(i,j,k)
 818         CALL wrf_debug(10,message)
 819       endif
 820         endif
 821           END DO
 822           END DO
 823
 824           DO k = kps , MIN(kde,kpe)
 825           inc_v=mod(jps,2)
 826           DO j = jps+inc_v, min(jde,jpe),2
 827         if (J .ge. 2 .and. J .le. JDE-1 .and. mod(J,2) .eq. 0) then
 828             ubdy3dtemp1(i,j,k) = grid%u(i,j,k)
 829             vbdy3dtemp1(i,j,k) = grid%v(i,j,k)
 830         endif
 831           END DO
 832           END DO
 833 !
 834           inc_h=mod(jps+1,2)
 835         DO j = jps+inc_h, min(jde,jpe),2
 836         if (J .ge. 3 .and. J .le. JDE-2 .and. mod(J,2) .eq. 1) then
 837             pdbdy2dtemp1(i,j,1) = grid%pd(i,j)
 838           write(message,*)' loop=',loop,' i=',i,' j=',j,' pdbdy2dtemp1(i,j)=',pdbdy2dtemp1(i,j,1)
 839           CALL wrf_debug(10,message)
 840         endif
 841           END DO
 842         ENDIF
 843 !
 844 !-----------------------------------------------------------------------
 845 !***  EASTERN BOUNDARY
 846 !-----------------------------------------------------------------------
 847 !
 848         IF(IPE==IDE)THEN
 849           I=MIN(IDE,IPE)
 850 !
 851           DO k = kps , MIN(kde,kpe)
 852 !
 853 !***   Make sure the J loop is on the global boundary
 854 !
 855           inc_h=mod(jps+1,2)
 856           DO j = jps+inc_h, min(jde,jpe),2
 857         if (J .ge. 3 .and. J .le. JDE-2 .and. mod(J,2) .eq. 1) then
 858             tbdy3dtemp1(i,j,k) = grid%t(i,j,k)
 859             qbdy3dtemp1(i,j,k) = grid%q(i,j,k)
 860             cwmbdy3dtemp1(i,j,k) = grid%cwm(i,j,k)
 861             q2bdy3dtemp1(i,j,k) = grid%q2(i,j,k)
 862         endif
 863           END DO
 864           END DO
 865
 866           DO k = kps , MIN(kde,kpe)
 867           inc_v=mod(jps,2)
 868           DO j = jps+inc_v, min(jde,jpe),2
 869         if (J .ge. 2 .and. J .le. JDE-1 .and. mod(J,2) .eq. 0) then
 870             ubdy3dtemp1(i,j,k) = grid%u(i,j,k)
 871             vbdy3dtemp1(i,j,k) = grid%v(i,j,k)
 872         endif
 873           END DO
 874           END DO
 875 !
 876           inc_h=mod(jps+1,2)
 877           DO j = jps+inc_h, min(jde,jpe),2
 878         if (J .ge. 3 .and. J .le. JDE-2 .and. mod(J,2) .eq. 1) then
 879             pdbdy2dtemp1(i,j,1) = grid%pd(i,j)
 880         endif
 881           END DO
 882         ENDIF
 883
 884
 885       !  There are 2 components to the lateral boundaries.
 886       !  First, there is the starting
 887       !  point of this time period - just the outer few rows and columns.
 888
 889
 890  CALL stuff_bdy_ijk (ubdy3dtemp1, grid%u_bxs, grid%u_bxe, &
 891                                   grid%u_bys, grid%u_bye, &
 892                                   'N', spec_bdy_width  , &
 893                                   ids , ide+1 , jds , jde+1 , kds , kde+1 , &
 894                                   ims , ime , jms , jme , kms , kme , &
 895                                   ips , ipe , jps , jpe , kps , kpe+1 )
 896
 897  CALL stuff_bdy_ijk (vbdy3dtemp1, grid%v_bxs, grid%v_bxe, &
 898                                   grid%v_bys, grid%v_bye, &
 899                                   'N', spec_bdy_width  , &
 900                                   ids , ide+1 , jds , jde+1 , kds , kde+1 , &
 901                                   ims , ime , jms , jme , kms , kme , &
 902                                   ips , ipe , jps , jpe , kps , kpe+1 )
 903
 904  CALL stuff_bdy_ijk (tbdy3dtemp1, grid%t_bxs, grid%t_bxe, &
 905                                   grid%t_bys, grid%t_bye, &
 906                                   'N', spec_bdy_width  , &
 907                                   ids , ide+1 , jds , jde+1 , kds , kde+1 , &
 908                                   ims , ime , jms , jme , kms , kme , &
 909                                   ips , ipe , jps , jpe , kps , kpe+1 )
 910
 911  CALL stuff_bdy_ijk (cwmbdy3dtemp1, grid%cwm_bxs, grid%cwm_bxe, &
 912                                   grid%cwm_bys, grid%cwm_bye, &
 913                                   'N', spec_bdy_width  , &
 914                                   ids , ide+1 , jds , jde+1 , kds , kde+1 , &
 915                                   ims , ime , jms , jme , kms , kme , &
 916                                   ips , ipe , jps , jpe , kps , kpe+1 )
 917
 918  CALL stuff_bdy_ijk (qbdy3dtemp1, grid%q_bxs, grid%q_bxe, &
 919                                   grid%q_bys, grid%q_bye, &
 920                                   'N', spec_bdy_width  , &
 921                                   ids , ide+1 , jds , jde+1 , kds , kde+1 , &
 922                                   ims , ime , jms , jme , kms , kme , &
 923                                   ips , ipe , jps , jpe , kps , kpe+1 )
 924
 925  CALL stuff_bdy_ijk (q2bdy3dtemp1, grid%q2_bxs, grid%q2_bxe, &
 926                                   grid%q2_bys, grid%q2_bye, &
 927                                   'N', spec_bdy_width  , &
 928                                   ids , ide+1 , jds , jde+1 , kds , kde+1 , &
 929                                   ims , ime , jms , jme , kms , kme , &
 930                                   ips , ipe , jps , jpe , kps , kpe+1 )
 931
 932
 933  CALL stuff_bdy_ijk (pdbdy2dtemp1, grid%pd_bxs, grid%pd_bxe, &
 934                                    grid%pd_bys, grid%pd_bye, &
 935                                    'M', spec_bdy_width, &
 936                                    ids , ide+1 , jds , jde+1 , 1 , 1 , &
 937                                    ims , ime , jms , jme , 1 , 1 , &
 938                                    ips , ipe , jps , jpe , 1 , 1 )
 939
 940 !-----------------------------------------------------------------------
 941 !
 942    ELSE IF ( loop .GT. 1 ) THEN
 943 !
 944 !-----------------------------------------------------------------------
 945
 946            CALL output_auxinput4 ( id4, grid , config_flags , ierr )
 947
 948       write(message,*)' assemble_output loop=',loop,' in IF block'
 949       call wrf_message(message)
 950
 951       !  Open the boundary file.
 952
 953       IF ( loop .eq. 2 ) THEN
 954          CALL construct_filename1( bdyname , 'wrfbdy' , grid%id , 2 )
 955       CALL open_w_dataset ( id, TRIM(bdyname) , grid , config_flags , &
 956                           output_boundary , "DATASET=BOUNDARY", ierr )
 957          IF ( ierr .NE. 0 ) THEN
 958                CALL wrf_error_fatal( 'real: error opening wrfbdy for writing' )
 959          ENDIF
 960 !         grid%write_metadata = .true.
 961       ELSE
 962 ! what's this do?
 963 !         grid%write_metadata = .true.
 964 !         grid%write_metadata = .false.
 965          CALL domain_clockadvance( grid )
 966       END IF
 967
 968 !-----------------------------------------------------------------------
 969 !***  SOUTHERN BOUNDARY
 970 !-----------------------------------------------------------------------
 971 !
 972         IF(JPS==JDS)THEN
 973           J=1
 974           DO k = kps , MIN(kde,kpe)
 975           DO i = ips , MIN(ide,ipe)
 976             ubdy3dtemp2(i,j,k) = grid%u(i,j,k)
 977             vbdy3dtemp2(i,j,k) = grid%v(i,j,k)
 978             tbdy3dtemp2(i,j,k) = grid%t(i,j,k)
 979             qbdy3dtemp2(i,j,k) = grid%q(i,j,k)
 980             cwmbdy3dtemp2(i,j,k) = grid%cwm(i,j,k)
 981             q2bdy3dtemp2(i,j,k) = grid%q2(i,j,k)
 982           END DO
 983           END DO
 984 !
 985           DO i = ips , MIN(ide,ipe)
 986             pdbdy2dtemp2(i,j,1) = grid%pd(i,j)
 987           END DO
 988         ENDIF
 989
 990 !
 991 !-----------------------------------------------------------------------
 992 !***  NORTHERN BOUNDARY
 993 !-----------------------------------------------------------------------
 994 !
 995         IF(JPE==JDE)THEN
 996           J=MIN(JDE,JPE)
 997           DO k = kps , MIN(kde,kpe)
 998           DO i = ips , MIN(ide,ipe)
 999             ubdy3dtemp2(i,j,k) = grid%u(i,j,k)
1000             vbdy3dtemp2(i,j,k) = grid%v(i,j,k)
1001             tbdy3dtemp2(i,j,k) = grid%t(i,j,k)
1002             qbdy3dtemp2(i,j,k) = grid%q(i,j,k)
1003             cwmbdy3dtemp2(i,j,k) = grid%cwm(i,j,k)
1004             q2bdy3dtemp2(i,j,k) = grid%q2(i,j,k)
1005           END DO
1006           END DO
1007
1008           DO i = ips , MIN(ide,ipe)
1009             pdbdy2dtemp2(i,j,1) = grid%pd(i,j)
1010           END DO
1011         ENDIF
1012 !
1013 !-----------------------------------------------------------------------
1014 !***  WESTERN BOUNDARY
1015 !-----------------------------------------------------------------------
1016 !
1017         IF(IPS==IDS)THEN
1018           I=1
1019           DO k = kps , MIN(kde,kpe)
1020           inc_h=mod(jps+1,2)
1021       if(k==1)then
1022         write(message,*)' assemble_ouput loop=',loop,' inc_h=',inc_h,' jps=',jps
1023         call wrf_debug(10,message)
1024       endif
1025           DO j = jps+inc_h, MIN(jde,jpe),2
1026         if (J .ge. 3 .and. J .le. jde-2 .and. mod(J,2) .eq. 1) then
1027             tbdy3dtemp2(i,j,k) = grid%t(i,j,k)
1028       if(k==1)then
1029         write(message,*)' loop=',loop,' i=',i,' j=',j,' tbdy3dtemp1(i,j,k)=',tbdy3dtemp1(i,j,k)
1030         call wrf_debug(10,message)
1031       endif
1032             qbdy3dtemp2(i,j,k) = grid%q(i,j,k)
1033             cwmbdy3dtemp2(i,j,k) = grid%cwm(i,j,k)
1034             q2bdy3dtemp2(i,j,k) = grid%q2(i,j,k)
1035         endif
1036           END DO
1037           END DO
1038 !
1039           DO k = kps , MIN(kde,kpe)
1040           inc_v=mod(jps,2)
1041           DO j = jps+inc_v, MIN(jde,jpe),2
1042         if (J .ge. 2 .and. J .le. jde-1 .and. mod(J,2) .eq. 0) then
1043             ubdy3dtemp2(i,j,k) = grid%u(i,j,k)
1044             vbdy3dtemp2(i,j,k) = grid%v(i,j,k)
1045         endif
1046           END DO
1047           END DO
1048
1049           inc_h=mod(jps+1,2)
1050         DO j = jps+inc_h, MIN(jde,jpe),2
1051         if (J .ge. 3 .and. J .le. jde-2 .and. mod(J,2) .eq. 1) then
1052           pdbdy2dtemp2(i,j,1) = grid%pd(i,j)
1053           write(message,*)' loop=',loop,' i=',i,' j=',j,' pdbdy2dtemp1(i,j)=',pdbdy2dtemp1(i,j,1)
1054           CALL wrf_debug(10,message)
1055         endif
1056           END DO
1057         ENDIF
1058 !
1059 !-----------------------------------------------------------------------
1060 !***  EASTERN BOUNDARY
1061 !-----------------------------------------------------------------------
1062 !
1063         IF(IPE==IDE)THEN
1064           I=MIN(IDE,IPE)
1065
1066           DO k = kps , MIN(kde,kpe)
1067           inc_h=mod(jps+1,2)
1068           DO j = jps+inc_h, MIN(jde,jpe),2
1069         if (J .ge. 3 .and. J .le. jde-2 .and. mod(J,2) .eq. 1) then
1070             tbdy3dtemp2(i,j,k) = grid%t(i,j,k)
1071             qbdy3dtemp2(i,j,k) = grid%q(i,j,k)
1072             cwmbdy3dtemp2(i,j,k) = grid%cwm(i,j,k)
1073             q2bdy3dtemp2(i,j,k) = grid%q2(i,j,k)
1074         endif
1075           END DO
1076           END DO
1077
1078           DO k = kps , MIN(kde,kpe)
1079           inc_v=mod(jps,2)
1080           DO j = jps+inc_v, MIN(jde,jpe),2
1081         if (J .ge. 2 .and. J .le. jde-1 .and. mod(J,2) .eq. 0) then
1082             ubdy3dtemp2(i,j,k) = grid%u(i,j,k)
1083             vbdy3dtemp2(i,j,k) = grid%v(i,j,k)
1084         endif
1085           END DO
1086           END DO
1087
1088           inc_h=mod(jps+1,2)
1089           DO j = jps+inc_h, MIN(jde,jpe),2
1090         if (J .ge. 3 .and. J .le. jde-2 .and. mod(J,2) .eq. 1) then
1091             pdbdy2dtemp2(i,j,1) = grid%pd(i,j)
1092         endif
1093           END DO
1094         ENDIF
1095 !-----------------------------------------------------------------------
1096       !  During all of the loops after the first loop,
1097       !  we first compute the boundary
1098       !  tendencies with the current data values
1099       !  (*bdy3dtemp2 arrays) and the previously
1100       !  saved information stored in the *bdy3dtemp1 arrays.
1101
1102
1103       CALL stuff_bdytend_ijk ( ubdy3dtemp2 , ubdy3dtemp1 , REAL(interval_seconds),&
1104                                    grid%u_btxs, grid%u_btxe, &
1105                                    grid%u_btys, grid%u_btye, &
1106                                    'N',  spec_bdy_width      , &
1107                                    ids , ide+1 , jds , jde+1 , kds , kde+1 , &
1108                                    ims , ime , jms , jme , kms , kme , &
1109                                    ips , ipe , jps , jpe , kps , kpe+1 )
1110
1111       CALL stuff_bdytend_ijk ( vbdy3dtemp2 , vbdy3dtemp1 , REAL(interval_seconds),&
1112                                    grid%v_btxs, grid%v_btxe, &
1113                                    grid%v_btys, grid%v_btye, &
1114                                    'N',  spec_bdy_width      , &
1115                                    ids , ide+1 , jds , jde+1 , kds , kde+1 , &
1116                                    ims , ime , jms , jme , kms , kme , &
1117                                    ips , ipe , jps , jpe , kps , kpe+1 )
1118
1119       CALL stuff_bdytend_ijk ( tbdy3dtemp2 , tbdy3dtemp1 , REAL(interval_seconds),&
1120                                    grid%t_btxs, grid%t_btxe, &
1121                                    grid%t_btys, grid%t_btye, &
1122                                    'N',  spec_bdy_width      , &
1123                                    ids , ide+1 , jds , jde+1 , kds , kde+1 , &
1124                                    ims , ime , jms , jme , kms , kme , &
1125                                    ips , ipe , jps , jpe , kps , kpe+1 )
1126
1127       CALL stuff_bdytend_ijk ( cwmbdy3dtemp2 , cwmbdy3dtemp1 , REAL(interval_seconds),&
1128                                    grid%cwm_btxs, grid%cwm_btxe, &
1129                                    grid%cwm_btys, grid%cwm_btye, &
1130                                    'N',  spec_bdy_width      , &
1131                                    ids , ide+1 , jds , jde+1 , kds , kde+1 , &
1132                                    ims , ime , jms , jme , kms , kme , &
1133                                    ips , ipe , jps , jpe , kps , kpe+1 )
1134
1135       CALL stuff_bdytend_ijk ( qbdy3dtemp2 , qbdy3dtemp1 , REAL(interval_seconds),&
1136                                    grid%q_btxs, grid%q_btxe, &
1137                                    grid%q_btys, grid%q_btye, &
1138                                    'N',  spec_bdy_width      , &
1139                                    ids , ide+1 , jds , jde+1 , kds , kde+1 , &
1140                                    ims , ime , jms , jme , kms , kme , &
1141                                    ips , ipe , jps , jpe , kps , kpe+1 )
1142
1143       CALL stuff_bdytend_ijk ( q2bdy3dtemp2 , q2bdy3dtemp1 , REAL(interval_seconds),&
1144                                    grid%q2_btxs, grid%q2_btxe, &
1145                                    grid%q2_btys, grid%q2_btye, &
1146                                    'N',  spec_bdy_width      , &
1147                                    ids , ide+1 , jds , jde+1 , kds , kde+1 , &
1148                                    ims , ime , jms , jme , kms , kme , &
1149                                    ips , ipe , jps , jpe , kps , kpe+1 )
1150
1151       CALL stuff_bdytend_ijk( pdbdy2dtemp2 , pdbdy2dtemp1, REAL(interval_seconds),&
1152                                    grid%pd_btxs, grid%pd_btxe, &
1153                                    grid%pd_btys, grid%pd_btye, &
1154                                    'M',  spec_bdy_width      , &
1155                                    ids , ide+1 , jds , jde+1 , 1 , 1 , &
1156                                    ims , ime   , jms , jme   , 1 , 1 , &
1157                                    ips , ipe   , jps , jpe   , 1 , 1 )
1158
1159
1160
1161       !  Both pieces of the boundary data are now
1162       !  available to be written (initial time and tendency).
1163       !  This looks ugly, these date shifting things.
1164       !  What's it for?  We want the "Times" variable
1165       !  in the lateral BDY file to have the valid times
1166       !  of when the initial fields are written.
1167       !  That's what the loop-2 thingy is for with the start date.
1168       !  We increment the start_date so
1169       !  that the starting time in the attributes is the
1170       !  second time period.  Why you may ask.  I
1171       !  agree, why indeed.
1172
1173       temp24= current_date
1174       temp24b=start_date
1175       start_date = current_date
1176       CALL geth_newdate ( temp19 , temp24b(1:19) , &
1177                          (loop-2) * model_config_rec%interval_seconds )
1178       current_date = temp19 //  '.0000'
1179        CALL domain_clock_set( grid, current_date(1:19) )
1180       write(message,*) 'LBC valid between these times ',current_date, ' ',start_date
1181       CALL wrf_message(message)
1182
1183       CALL output_boundary ( id, grid , config_flags , ierr )
1184       current_date = temp24
1185       start_date = temp24b
1186
1187       !  OK, for all of the loops, we output the initialzation
1188       !  data, which would allow us to
1189       !  start the model at any of the available analysis time periods.
1190
1191 !  WRITE ( loop_char , FMT = '(I4.4)' ) loop
1192 !  CALL open_w_dataset ( id1, 'wrfinput'//loop_char , grid , config_flags , output_input , "DATASET=INPUT", ierr )
1193 !  IF ( ierr .NE. 0 ) THEN
1194 !    CALL wrf_error_fatal( 'real: error opening wrfinput'//loop_char//' for writing' )
1195 !  ENDIF
1196 !  grid%write_metadata = .true.
1197
1198 !  CALL calc_current_date ( grid%id , 0. )
1199 !  CALL output_input ( id1, grid , config_flags , ierr )
1200 !  CALL close_dataset ( id1 , config_flags , "DATASET=INPUT" )
1201
1202   !  Is this or is this not the last time time?  We can remove some unnecessary
1203   !  stores if it is not.
1204
1205       IF     ( loop .LT. time_loop_max ) THEN
1206
1207          !  We need to save the 3d data to compute a
1208          !  difference during the next loop.  Couple the
1209          !  3d fields with total mu (mub + mu_2) and the
1210          !  stagger-specific map scale factor.
1211          !  We load up the boundary data again for use in the next loop.
1212
1213
1214 !mp     change these limits?????????
1215
1216          DO k = kps , kpe
1217             DO j = jps , jpe
1218                DO i = ips , ipe
1219                   ubdy3dtemp1(i,j,k) = ubdy3dtemp2(i,j,k)
1220                   vbdy3dtemp1(i,j,k) = vbdy3dtemp2(i,j,k)
1221                   tbdy3dtemp1(i,j,k) = tbdy3dtemp2(i,j,k)
1222                   cwmbdy3dtemp1(i,j,k) = cwmbdy3dtemp2(i,j,k)
1223                   qbdy3dtemp1(i,j,k) = qbdy3dtemp2(i,j,k)
1224                   q2bdy3dtemp1(i,j,k) = q2bdy3dtemp2(i,j,k)
1225                END DO
1226             END DO
1227          END DO
1228
1229 !mp     change these limits?????????
1230
1231          DO j = jps , jpe
1232             DO i = ips , ipe
1233                pdbdy2dtemp1(i,j,1) = pdbdy2dtemp2(i,j,1)
1234         if (J .eq. jpe) write(0,*) 'I,J, PDBDy2dtemp1(i,j,1):' , I,J, PDBDy2dtemp1(i,j,1)
1235             END DO
1236          END DO
1237
1238   !  There are 2 components to the lateral boundaries.
1239   !   First, there is the starting
1240   !  point of this time period - just the outer few rows and columns.
1241
1242  CALL stuff_bdy_ijk (ubdy3dtemp1, grid%u_bxs, grid%u_bxe, &
1243                                   grid%u_bys, grid%u_bye, &
1244                                   'N', spec_bdy_width  , &
1245                                   ids , ide+1 , jds , jde+1 , kds , kde+1 , &
1246                                   ims , ime , jms , jme , kms , kme , &
1247                                   ips , ipe , jps , jpe , kps , kpe+1 )
1248
1249  CALL stuff_bdy_ijk (vbdy3dtemp1, grid%v_bxs, grid%v_bxe, &
1250                                   grid%v_bys, grid%v_bye, &
1251                                   'N', spec_bdy_width  , &
1252                                   ids , ide+1 , jds , jde+1 , kds , kde+1 , &
1253                                   ims , ime , jms , jme , kms , kme , &
1254                                   ips , ipe , jps , jpe , kps , kpe+1 )
1255
1256  CALL stuff_bdy_ijk (tbdy3dtemp1, grid%t_bxs, grid%t_bxe, &
1257                                   grid%t_bys, grid%t_bye, &
1258                                   'N', spec_bdy_width  , &
1259                                   ids , ide+1 , jds , jde+1 , kds , kde+1 , &
1260                                   ims , ime , jms , jme , kms , kme , &
1261                                   ips , ipe , jps , jpe , kps , kpe+1 )
1262
1263  CALL stuff_bdy_ijk (cwmbdy3dtemp1, grid%cwm_bxs, grid%cwm_bxe, &
1264                                   grid%cwm_bys, grid%cwm_bye, &
1265                                   'N', spec_bdy_width  , &
1266                                   ids , ide+1 , jds , jde+1 , kds , kde+1 , &
1267                                   ims , ime , jms , jme , kms , kme , &
1268                                   ips , ipe , jps , jpe , kps , kpe+1 )
1269
1270  CALL stuff_bdy_ijk (qbdy3dtemp1, grid%q_bxs, grid%q_bxe, &
1271                                   grid%q_bys, grid%q_bye, &
1272                                   'N', spec_bdy_width  , &
1273                                   ids , ide+1 , jds , jde+1 , kds , kde+1 , &
1274                                   ims , ime , jms , jme , kms , kme , &
1275                                   ips , ipe , jps , jpe , kps , kpe+1 )
1276
1277  CALL stuff_bdy_ijk (q2bdy3dtemp1, grid%q2_bxs, grid%q2_bxe, &
1278                                   grid%q2_bys, grid%q2_bye, &
1279                                   'N', spec_bdy_width  , &
1280                                   ids , ide+1 , jds , jde+1 , kds , kde+1 , &
1281                                   ims , ime , jms , jme , kms , kme , &
1282                                   ips , ipe , jps , jpe , kps , kpe+1 )
1283
1284  CALL stuff_bdy_ijk (pdbdy2dtemp1,grid%pd_bxs, grid%pd_bxe, &
1285                                   grid%pd_bys, grid%pd_bye, &
1286                                   'M', spec_bdy_width  , &
1287                                   ids , ide+1 , jds , jde+1 , 1 , 1 , &
1288                                   ims , ime , jms , jme , 1 , 1 , &
1289                                   ips , ipe , jps , jpe , 1 , 1 )
1290
1291       ELSE IF ( loop .EQ. time_loop_max ) THEN
1292
1293     !  If this is the last time through here, we need to close the files.
1294
1295          CALL close_dataset ( id , config_flags , "DATASET=BOUNDARY" )
1296
1297       END IF
1298
1299    END IF main_loop_test
1300
1301 END SUBROUTINE assemble_output