real_nmm.F
References to this file elsewhere.
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_si_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
308 using_binary_wrfsi=.false.
309
310
311 IF ( grid%dyn_opt .EQ. dyn_nmm ) THEN
312
313 write(message,*) 'TRIM(config_flags%auxinput1_inname): ', TRIM(config_flags%auxinput1_inname)
314 CALL wrf_message(message)
315
316 IF (config_flags%auxinput1_inname(1:10) .eq. 'real_input') THEN
317 using_binary_wrfsi=.true.
318 ENDIF
319
320 SELECT CASE ( use_package(io_form_auxinput1) )
321 #ifdef NETCDF
322 CASE ( IO_NETCDF )
323
324 ! Open the wrfinput file.
325
326 current_date_char(11:11)='_'
327
328 WRITE ( wrf_err_message , FMT='(A,A)' )'med_sidata_input: calling open_r_dataset for ',TRIM(config_flags%auxinput1_inname)
329 CALL wrf_debug ( 100 , wrf_err_message )
330 IF ( config_flags%auxinput1_inname(1:8) .NE. 'wrf_real' ) THEN
331 CALL construct_filename4a( si_inpname , config_flags%auxinput1_inname , grid%id , 2 , current_date_char , &
332 config_flags%io_form_auxinput1 )
333 ELSE
334 CALL construct_filename2a( si_inpname , config_flags%auxinput1_inname , grid%id , 2 , current_date_char )
335 END IF
336 CALL open_r_dataset ( idsi, TRIM(si_inpname) , grid , config_flags , "DATASET=AUXINPUT1", ierr )
337 IF ( ierr .NE. 0 ) THEN
338 CALL wrf_error_fatal( 'error opening ' // TRIM(si_inpname) // ' for input; bad date in namelist or file not in directory' )
339 ENDIF
340
341
342 ! Input data.
343
344 CALL wrf_debug (100, 'med_sidata_input: call input_aux_model_input1_wrf')
345 CALL input_aux_model_input1 ( idsi, grid, config_flags, ierr )
346
347 ! Possible optional SI input. This sets flags used by init_domain.
348
349 IF ( loop .EQ. 1 ) THEN
350 CALL wrf_debug (100, 'med_sidata_input: call init_module_optional_si_input' )
351 CALL init_module_optional_si_input ( grid , config_flags )
352 !mp END IF
353 CALL wrf_debug ( 100 , 'med_sidata_input: calling optional_si_input' )
354 CALL optional_si_input ( grid , idsi )
355
356 ENDIF
357
358 !
359 CALL close_dataset ( idsi , config_flags , "DATASET=AUXINPUT1" )
360
361 #endif
362 #ifdef INTIO
363 CASE ( IO_INTIO )
364
365 ! Possible optional SI input. This sets flags used by init_domain.
366
367 IF ( loop .EQ. 1 ) THEN
368 CALL wrf_debug (100, 'med_sidata_input: call init_module_optional_si_input' )
369 CALL init_module_optional_si_input ( grid , config_flags )
370 END IF
371
372 IF (using_binary_wrfsi) THEN
373
374 current_date_char(11:11)='_'
375 CALL read_si ( grid, current_date_char )
376 current_date_char(11:11)='T'
377
378 ELSE
379
380 write(message,*) 'binary WPS branch'
381 CALL wrf_message(message)
382 CALL wrf_error_fatal("binary WPS support deferred for initial release")
383
384 ! WRITE ( wrf_err_message , FMT='(A,A)' )'med_sidata_input: calling open_r_dataset for ',TRIM(config_flags%auxinput1_inname)
385 ! CALL wrf_debug ( 100 , wrf_err_message )
386 ! CALL construct_filename4a( si_inpname , config_flags%auxinput1_inname , grid%id , 2 , current_date_char , config_flags%io_form_auxinput1 )
387 ! CALL open_r_dataset ( idsi, TRIM(si_inpname) , grid , config_flags , "DATASET=AUXINPUT1", ierr )
388
389 ! IF ( ierr .NE. 0 ) THEN
390 ! CALL wrf_debug( 1 , 'error opening ' // TRIM(si_inpname) // ' for input; bad date in namelist or file not in directory' )
391 ! CALL wrf_debug( 1 , 'will try again without the extension' )
392 ! CALL construct_filename2a( si_inpname , config_flags%auxinput1_inname , grid%id , 2 , current_date_char )
393 ! CALL open_r_dataset ( idsi, TRIM(si_inpname) , grid , config_flags , "DATASET=AUXINPUT1", ierr )
394 ! IF ( ierr .NE. 0 ) THEN
395 ! CALL wrf_error_fatal( 'error opening ' // TRIM(si_inpname) // ' for input; bad date in namelist or file not in directory' )
396 ! ENDIF
397 ! ENDIF
398
399 ! Input data.
400
401 !!! believe problematic as binary data from WPS will be XYZ ordered, while this
402 !!! version of WRF will read in as XZY. OR read all fields in as unique
403 !!! Registry items that are XYZ, then swap. More memory, and more overhead, but
404 !!! better than having a stand alone "read_si" type code??
405
406 ! CALL wrf_debug (100, 'med_sidata_input: call input_aux_model_input1_wrf')
407 ! CALL input_aux_model_input1 ( idsi, grid, config_flags, ierr )
408
409 ! Possible optional SI input. This sets flags used by init_domain.
410
411 ! IF ( loop .EQ. 1 ) THEN
412 ! CALL wrf_debug (100, 'med_sidata_input: call init_module_optional_si_input' )
413 ! CALL init_module_optional_si_input ( grid , config_flags )
414 ! END IF
415 ! CALL wrf_debug ( 100 , 'med_sidata_input: calling optional_si_input' )
416 !
417 ! CALL optional_si_input ( grid , idsi )
418 ! flag_metgrid=1
419
420 !
421 ! CALL close_dataset ( idsi , config_flags , "DATASET=AUXINPUT1" )
422
423 ENDIF
424 #endif
425 CASE DEFAULT
426 CALL wrf_error_fatal('real: not valid io_form_auxinput1')
427 END SELECT
428
429 ELSE
430 call wrf_error_fatal("WRONG DYNAMICAL CORE SELECTED FOR THIS VERSION OF REAL - CHECK dyn_opt in namelist.input file")
431 ENDIF
432
433 grid%nmm_islope=1
434 grid%vegfra=grid%nmm_vegfrc
435 grid%nmm_dfrlg=grid%nmm_dfl/9.81
436
437 grid%isurban=1
438 grid%isoilwater=14
439
440 ! Initialize the mother domain for this time period with input data.
441
442 CALL wrf_debug ( 100 , 'med_sidata_input: calling init_domain' )
443 grid%input_from_file = .true.
444
445 CALL init_domain ( grid )
446
447 CALL model_to_grid_config_rec ( grid%id, model_config_rec, config_flags )
448
449 ! Close this file that is output from the SI and input to this pre-proc.
450
451 CALL wrf_debug ( 100 , 'med_sidata_input: back from init_domain' )
452
453
454 !!! not sure about this, but doesnt seem like needs to be called each time
455 IF ( loop .EQ. 1 ) THEN
456 CALL start_domain ( grid , .TRUE.)
457 END IF
458
459 #ifdef WRF_CHEM
460 IF ( loop == 1 ) THEN
461 ! IF ( ( grid%chem_opt .EQ. RADM2 ) .OR. &
462 ! ( grid%chem_opt .EQ. RADM2SORG ) .OR. &
463 ! ( grid%chem_opt .EQ. RACM ) .OR. &
464 ! ( grid%chem_opt .EQ. RACMSORG ) ) THEN
465 IF( grid%chem_opt > 0 ) then
466 ! Read the chemistry data from a previous wrf forecast (wrfout file)
467 IF(grid%chem_in_opt == 1 ) THEN
468 message = 'INITIALIZING CHEMISTRY WITH OLD SIMULATION'
469 CALL wrf_message ( message )
470
471 CALL input_ext_chem_file( grid )
472
473 IF(grid%bio_emiss_opt == BEIS311 ) THEN
474 message = 'READING BEIS3.11 EMISSIONS DATA'
475 CALL wrf_message ( message )
476 CALL med_read_wrf_chem_bioemiss ( grid , config_flags)
477 END IF
478
479 ELSEIF(grid%chem_in_opt == 0)then
480 ! Generate chemistry data from a idealized vertical profile
481 message = 'STARTING WITH BACKGROUND CHEMISTRY '
482 CALL wrf_message ( message )
483
484 write(message,*)' ETA1 '
485 CALL wrf_message ( message )
486 ! write(message,*) grid%nmm_eta1
487 ! CALL wrf_message ( message )
488
489 CALL input_chem_profile ( grid )
490
491 IF(grid%bio_emiss_opt == BEIS311 ) THEN
492 message = 'READING BEIS3.11 EMISSIONS DATA'
493 CALL wrf_message ( message )
494 CALL med_read_wrf_chem_bioemiss ( grid , config_flags)
495 END IF
496
497 ELSE
498 message = 'RUNNING WITHOUT CHEMISTRY INITIALIZATION'
499 CALL wrf_message ( message )
500 ENDIF
501 ENDIF
502 ENDIF
503 #endif
504
505 config_flags%isurban=1
506 config_flags%isoilwater=14
507
508 CALL assemble_output ( grid , config_flags , loop , time_loop_max )
509
510 ! Here we define the next time that we are going to process.
511
512 CALL geth_newdate ( current_date_char , start_date_char , &
513 loop * model_config_rec%interval_seconds )
514 current_date = current_date_char // '.0000'
515
516 CALL domain_clock_set( grid, current_date(1:19) )
517
518 write(message,*) 'current_date= ', current_date
519 CALL wrf_message(message)
520
521 END DO
522 END SUBROUTINE med_sidata_input
523
524 SUBROUTINE compute_si_start_and_end ( &
525 start_year, start_month, start_day, start_hour, &
526 start_minute, start_second, &
527 end_year , end_month , end_day , end_hour , &
528 end_minute , end_second , &
529 interval_seconds , real_data_init_type , &
530 start_date_char , end_date_char , time_loop_max )
531
532 USE module_date_time
533
534 IMPLICIT NONE
535
536 INTEGER :: start_year , start_month , start_day , &
537 start_hour , start_minute , start_second
538 INTEGER :: end_year , end_month , end_day , &
539 end_hour , end_minute , end_second
540 INTEGER :: interval_seconds , real_data_init_type
541 INTEGER :: time_loop_max , time_loop
542
543 CHARACTER(LEN=132) :: message
544 CHARACTER(LEN=19) :: current_date_char , start_date_char , &
545 end_date_char , next_date_char
546
547 ! WRITE ( start_date_char , FMT = &
548 ! '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) &
549 ! start_year,start_month,start_day,start_hour,start_minute,start_second
550 ! WRITE ( end_date_char , FMT = &
551 ! '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) &
552 ! end_year, end_month, end_day, end_hour, end_minute, end_second
553
554 WRITE ( start_date_char , FMT = &
555 '(I4.4,"-",I2.2,"-",I2.2,"T",I2.2,":",I2.2,":",I2.2)' ) &
556 start_year,start_month,start_day,start_hour,start_minute,start_second
557 WRITE ( end_date_char , FMT = &
558 '(I4.4,"-",I2.2,"-",I2.2,"T",I2.2,":",I2.2,":",I2.2)' ) &
559 end_year, end_month, end_day, end_hour, end_minute, end_second
560
561 ! start_date = start_date_char // '.0000'
562
563 ! Figure out our loop count for the processing times.
564
565 time_loop = 1
566 PRINT '(A,I4,A,A,A)','Time period #',time_loop, &
567 ' to process = ',start_date_char,'.'
568 current_date_char = start_date_char
569 loop_count : DO
570 CALL geth_newdate (next_date_char, current_date_char, interval_seconds )
571 IF ( next_date_char .LT. end_date_char ) THEN
572 time_loop = time_loop + 1
573 PRINT '(A,I4,A,A,A)','Time period #',time_loop,&
574 ' to process = ',next_date_char,'.'
575 current_date_char = next_date_char
576 ELSE IF ( next_date_char .EQ. end_date_char ) THEN
577 time_loop = time_loop + 1
578 PRINT '(A,I4,A,A,A)','Time period #',time_loop,&
579 ' to process = ',next_date_char,'.'
580 PRINT '(A,I4,A)','Total analysis times to input = ',time_loop,'.'
581 time_loop_max = time_loop
582 EXIT loop_count
583 ELSE IF ( next_date_char .GT. end_date_char ) THEN
584 PRINT '(A,I4,A)','Total analysis times to input = ',time_loop,'.'
585 time_loop_max = time_loop
586 EXIT loop_count
587 END IF
588 END DO loop_count
589 write(message,*) 'done in si_start_and_end'
590 CALL wrf_message(message)
591 END SUBROUTINE compute_si_start_and_end
592
593 SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max )
594
595 !!! replace with something? USE module_big_step_utilities_em
596
597 USE module_domain
598 USE module_io_domain
599 USE module_configure
600 USE module_date_time
601 USE module_bc
602 IMPLICIT NONE
603
604 TYPE(domain) :: grid
605 TYPE (grid_config_rec_type) :: config_flags
606 INTEGER , INTENT(IN) :: loop , time_loop_max
607
608 INTEGER :: ids , ide , jds , jde , kds , kde
609 INTEGER :: ims , ime , jms , jme , kms , kme
610 INTEGER :: ips , ipe , jps , jpe , kps , kpe
611 INTEGER :: ijds , ijde , spec_bdy_width
612 INTEGER :: inc_h,inc_v
613 INTEGER :: i , j , k , idts
614
615 INTEGER :: id1 , interval_seconds , ierr, rc
616 INTEGER , SAVE :: id
617 CHARACTER (LEN=80) :: inpname , bdyname
618 CHARACTER(LEN= 4) :: loop_char
619 CHARACTER(LEN=132) :: message
620 character *19 :: temp19
621 character *24 :: temp24 , temp24b
622
623 REAL, DIMENSION(:,:,:), ALLOCATABLE, SAVE :: ubdy3dtemp1 , vbdy3dtemp1 ,&
624 tbdy3dtemp1 , &
625 cwmbdy3dtemp1 , qbdy3dtemp1,&
626 q2bdy3dtemp1 , pdbdy2dtemp1
627 REAL, DIMENSION(:,:,:), ALLOCATABLE, SAVE :: ubdy3dtemp2 , vbdy3dtemp2 , &
628 tbdy3dtemp2 , &
629 cwmbdy3dtemp2 , qbdy3dtemp2, &
630 q2bdy3dtemp2, pdbdy2dtemp2
631 REAL :: t1,t2
632
633 #ifdef DEREF_KLUDGE
634 ! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
635 INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33
636 INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x
637 INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y
638 #endif
639
640 #include "deref_kludge.h"
641
642
643 ! Various sizes that we need to be concerned about.
644
645 ids = grid%sd31
646 ide = grid%ed31-1 ! 030730tst
647 kds = grid%sd32
648 kde = grid%ed32-1 ! 030730tst
649 jds = grid%sd33
650 jde = grid%ed33-1 ! 030730tst
651
652 ims = grid%sm31
653 ime = grid%em31
654 kms = grid%sm32
655 kme = grid%em32
656 jms = grid%sm33
657 jme = grid%em33
658
659 ips = grid%sp31
660 ipe = grid%ep31-1 ! 030730tst
661 kps = grid%sp32
662 kpe = grid%ep32-1 ! 030730tst
663 jps = grid%sp33
664 jpe = grid%ep33-1 ! 030730tst
665
666 if (IPE .ne. IDE) IPE=IPE+1
667 if (JPE .ne. JDE) JPE=JPE+1
668
669 write(message,*) 'assemble output (ids,ide): ', ids,ide
670 CALL wrf_message(message)
671 write(message,*) 'assemble output (ims,ime): ', ims,ime
672 CALL wrf_message(message)
673 write(message,*) 'assemble output (ips,ipe): ', ips,ipe
674 CALL wrf_message(message)
675
676 write(message,*) 'assemble output (jds,jde): ', jds,jde
677 CALL wrf_message(message)
678 write(message,*) 'assemble output (jms,jme): ', jms,jme
679 CALL wrf_message(message)
680 write(message,*) 'assemble output (jps,jpe): ', jps,jpe
681 CALL wrf_message(message)
682
683 write(message,*) 'assemble output (kds,kde): ', kds,kde
684 CALL wrf_message(message)
685 write(message,*) 'assemble output (kms,kme): ', kms,kme
686 CALL wrf_message(message)
687 write(message,*) 'assemble output (kps,kpe): ', kps,kpe
688 CALL wrf_message(message)
689
690 ijds = MIN ( ids , jds )
691 !mptest030805 ijde = MAX ( ide , jde )
692 ijde = MAX ( ide , jde ) + 1 ! to make stuff_bdy dimensions consistent with alloc
693
694 ! Boundary width, scalar value.
695
696 spec_bdy_width = model_config_rec%spec_bdy_width
697 interval_seconds = model_config_rec%interval_seconds
698
699 !-----------------------------------------------------------------------
700 !
701 main_loop_test: IF ( loop .EQ. 1 ) THEN
702 !
703 !-----------------------------------------------------------------------
704
705 ! This is the space needed to save the current 3d data for use in computing
706 ! the lateral boundary tendencies.
707
708 ALLOCATE ( ubdy3dtemp1(ims:ime,kms:kme,jms:jme) )
709 ALLOCATE ( vbdy3dtemp1(ims:ime,kms:kme,jms:jme) )
710 ALLOCATE ( tbdy3dtemp1(ims:ime,kms:kme,jms:jme) )
711 ALLOCATE ( qbdy3dtemp1(ims:ime,kms:kme,jms:jme) )
712 ALLOCATE ( cwmbdy3dtemp1(ims:ime,kms:kme,jms:jme) )
713 ALLOCATE ( q2bdy3dtemp1(ims:ime,kms:kme,jms:jme) )
714 ALLOCATE ( pdbdy2dtemp1(ims:ime, 1:1 ,jms:jme) )
715
716 ubdy3dtemp1=0.
717 vbdy3dtemp1=0.
718 tbdy3dtemp1=0.
719 qbdy3dtemp1=0.
720 cwmbdy3dtemp1=0.
721 q2bdy3dtemp1=0.
722 pdbdy2dtemp1=0.
723
724 ALLOCATE ( ubdy3dtemp2(ims:ime,kms:kme,jms:jme) )
725 ALLOCATE ( vbdy3dtemp2(ims:ime,kms:kme,jms:jme) )
726 ALLOCATE ( tbdy3dtemp2(ims:ime,kms:kme,jms:jme) )
727 ALLOCATE ( qbdy3dtemp2(ims:ime,kms:kme,jms:jme) )
728 ALLOCATE ( cwmbdy3dtemp2(ims:ime,kms:kme,jms:jme) )
729 ALLOCATE ( q2bdy3dtemp2(ims:ime,kms:kme,jms:jme) )
730 ALLOCATE ( pdbdy2dtemp2(ims:ime, 1:1 ,jms:jme) )
731
732 ubdy3dtemp2=0.
733 vbdy3dtemp2=0.
734 tbdy3dtemp2=0.
735 qbdy3dtemp2=0.
736 cwmbdy3dtemp2=0.
737 q2bdy3dtemp2=0.
738 pdbdy2dtemp2=0.
739
740 ! Open the wrfinput file. From this program, this is an *output* file.
741
742 CALL construct_filename1( inpname , 'wrfinput' , grid%id , 2 )
743
744 CALL open_w_dataset ( id1, TRIM(inpname) , grid , config_flags , &
745 output_model_input , "DATASET=INPUT", ierr )
746
747 IF ( ierr .NE. 0 ) THEN
748 CALL wrf_error_fatal( 'real: error opening wrfinput for writing' )
749 ENDIF
750
751 ! CALL calc_current_date ( grid%id , 0. )
752 ! grid%write_metadata = .true.
753
754 write(message,*) 'making call to output_model_input'
755 CALL wrf_message(message)
756
757 CALL output_model_input ( id1, grid , config_flags , ierr )
758
759 !***
760 !*** CLOSE THE WRFINPUT DATASET
761 !***
762 CALL close_dataset ( id1 , config_flags , "DATASET=INPUT" )
763
764 ! We need to save the 3d data to compute a
765 ! difference during the next loop.
766
767 !
768 !-----------------------------------------------------------------------
769 !*** SOUTHERN BOUNDARY
770 !-----------------------------------------------------------------------
771 !
772
773 IF(JPS==JDS)THEN
774 J=1
775 DO k = kps , MIN(kde,kpe)
776 DO i = ips , MIN(ide,ipe)
777 ubdy3dtemp1(i,k,j) = grid%nmm_u(i,k,j)
778 vbdy3dtemp1(i,k,j) = grid%nmm_v(i,k,j)
779 tbdy3dtemp1(i,k,j) = grid%nmm_t(i,k,j)
780 qbdy3dtemp1(i,k,j) = grid%nmm_q(i,k,j)
781 cwmbdy3dtemp1(i,k,j) = grid%nmm_cwm(i,k,j)
782 q2bdy3dtemp1(i,k,j) = grid%nmm_q2(i,k,j)
783 END DO
784 END DO
785
786 DO i = ips , MIN(ide,ipe)
787 pdbdy2dtemp1(i,1,j) = grid%nmm_pd(i,j)
788 END DO
789 ENDIF
790
791 !
792 !-----------------------------------------------------------------------
793 !*** NORTHERN BOUNDARY
794 !-----------------------------------------------------------------------
795 !
796 IF(JPE==JDE)THEN
797 J=MIN(JDE,JPE)
798 DO k = kps , MIN(kde,kpe)
799 DO i = ips , MIN(ide,ipe)
800 ubdy3dtemp1(i,k,j) = grid%nmm_u(i,k,j)
801 vbdy3dtemp1(i,k,j) = grid%nmm_v(i,k,j)
802 tbdy3dtemp1(i,k,j) = grid%nmm_t(i,k,j)
803 qbdy3dtemp1(i,k,j) = grid%nmm_q(i,k,j)
804 cwmbdy3dtemp1(i,k,j) = grid%nmm_cwm(i,k,j)
805 q2bdy3dtemp1(i,k,j) = grid%nmm_q2(i,k,j)
806 END DO
807 END DO
808
809 DO i = ips , MIN(ide,ipe)
810 pdbdy2dtemp1(i,1,j) = grid%nmm_pd(i,j)
811 END DO
812 ENDIF
813
814 !
815 !-----------------------------------------------------------------------
816 !*** WESTERN BOUNDARY
817 !-----------------------------------------------------------------------
818 !
819 write(message,*) 'western boundary, store winds over J: ', jps, min(jpe,jde)
820 CALL wrf_message(message)
821 IF(IPS==IDS)THEN
822 I=1
823 DO k = kps , MIN(kde,kpe)
824 inc_h=mod(jps+1,2)
825 DO j = jps+inc_h, min(jde,jpe),2
826
827 if (J .ge. 3 .and. J .le. JDE-2 .and. mod(J,2) .eq. 1) then
828 tbdy3dtemp1(i,k,j) = grid%nmm_t(i,k,j)
829 qbdy3dtemp1(i,k,j) = grid%nmm_q(i,k,j)
830 cwmbdy3dtemp1(i,k,j) = grid%nmm_cwm(i,k,j)
831 q2bdy3dtemp1(i,k,j) = grid%nmm_q2(i,k,j)
832 if(k==1)then
833 write(message,*)' loop=',loop,' i=',i,' j=',j,' tbdy3dtemp1(i,k,j)=',tbdy3dtemp1(i,k,j)
834 CALL wrf_debug(10,message)
835 endif
836 endif
837 END DO
838 END DO
839
840 DO k = kps , MIN(kde,kpe)
841 inc_v=mod(jps,2)
842 DO j = jps+inc_v, min(jde,jpe),2
843 if (J .ge. 2 .and. J .le. JDE-1 .and. mod(J,2) .eq. 0) then
844 ubdy3dtemp1(i,k,j) = grid%nmm_u(i,k,j)
845 vbdy3dtemp1(i,k,j) = grid%nmm_v(i,k,j)
846 endif
847 END DO
848 END DO
849 !
850 inc_h=mod(jps+1,2)
851 DO j = jps+inc_h, min(jde,jpe),2
852 if (J .ge. 3 .and. J .le. JDE-2 .and. mod(J,2) .eq. 1) then
853 pdbdy2dtemp1(i,1,j) = grid%nmm_pd(i,j)
854 write(message,*)' loop=',loop,' i=',i,' j=',j,' pdbdy2dtemp1(i,1,j)=',pdbdy2dtemp1(i,1,j)
855 CALL wrf_debug(10,message)
856 endif
857 END DO
858 ENDIF
859 !
860 !-----------------------------------------------------------------------
861 !*** EASTERN BOUNDARY
862 !-----------------------------------------------------------------------
863 !
864 IF(IPE==IDE)THEN
865 I=MIN(IDE,IPE)
866 !
867 DO k = kps , MIN(kde,kpe)
868 !
869 !*** Make sure the J loop is on the global boundary
870 !
871 inc_h=mod(jps+1,2)
872 DO j = jps+inc_h, min(jde,jpe),2
873 if (J .ge. 3 .and. J .le. JDE-2 .and. mod(J,2) .eq. 1) then
874 tbdy3dtemp1(i,k,j) = grid%nmm_t(i,k,j)
875 qbdy3dtemp1(i,k,j) = grid%nmm_q(i,k,j)
876 cwmbdy3dtemp1(i,k,j) = grid%nmm_cwm(i,k,j)
877 q2bdy3dtemp1(i,k,j) = grid%nmm_q2(i,k,j)
878 endif
879 END DO
880 END DO
881
882 DO k = kps , MIN(kde,kpe)
883 inc_v=mod(jps,2)
884 DO j = jps+inc_v, min(jde,jpe),2
885 if (J .ge. 2 .and. J .le. JDE-1 .and. mod(J,2) .eq. 0) then
886 ubdy3dtemp1(i,k,j) = grid%nmm_u(i,k,j)
887 vbdy3dtemp1(i,k,j) = grid%nmm_v(i,k,j)
888 endif
889 END DO
890 END DO
891 !
892 inc_h=mod(jps+1,2)
893 DO j = jps+inc_h, min(jde,jpe),2
894 if (J .ge. 3 .and. J .le. JDE-2 .and. mod(J,2) .eq. 1) then
895 pdbdy2dtemp1(i,1,j) = grid%nmm_pd(i,j)
896 endif
897 END DO
898 ENDIF
899
900
901 ! There are 2 components to the lateral boundaries.
902 ! First, there is the starting
903 ! point of this time period - just the outer few rows and columns.
904
905
906 CALL stuff_bdy (ubdy3dtemp1, grid%nmm_u_b, 'N', ijds, ijde, 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 CALL stuff_bdy ( vbdy3dtemp1, grid%nmm_v_b, 'N', ijds, ijde, spec_bdy_width, &
911 ids , ide+1 , jds , jde+1 , kds , kde+1 , &
912 ims , ime , jms , jme , kms , kme , &
913 ips , ipe , jps , jpe , kps , kpe+1 )
914 CALL stuff_bdy ( tbdy3dtemp1, grid%nmm_t_b, 'N', ijds, ijde, spec_bdy_width, &
915 ids , ide+1 , jds , jde+1 , kds , kde+1 , &
916 ims , ime , jms , jme , kms , kme , &
917 ips , ipe , jps , jpe , kps , kpe+1 )
918
919 CALL stuff_bdy ( cwmbdy3dtemp1,grid%nmm_cwm_b,'N',ijds,ijde, spec_bdy_width, &
920 ids , ide+1 , jds , jde+1 , kds , kde+1 , &
921 ims , ime , jms , jme , kms , kme , &
922 ips , ipe , jps , jpe , kps , kpe+1 )
923
924 CALL stuff_bdy ( qbdy3dtemp1, grid%nmm_q_b, 'N', ijds, ijde, spec_bdy_width, &
925 ids , ide+1 , jds , jde+1 , kds , kde+1 , &
926 ims , ime , jms , jme , kms , kme , &
927 ips , ipe , jps , jpe , kps , kpe+1 )
928
929 CALL stuff_bdy ( q2bdy3dtemp1,grid%nmm_q2_b,'N', ijds, ijde, spec_bdy_width, &
930 ids , ide+1 , jds , jde+1 , kds , kde+1 , &
931 ims , ime , jms , jme , kms , kme , &
932 ips , ipe , jps , jpe , kps , kpe+1 )
933
934 CALL stuff_bdy ( pdbdy2dtemp1,grid%nmm_pd_b,'M', ijds,ijde, spec_bdy_width, &
935 ids , ide+1 , jds , jde+1 , 1 , 1 , &
936 ims , ime , jms , jme , 1 , 1 , &
937 ips , ipe , jps , jpe , 1 , 1 )
938
939 !-----------------------------------------------------------------------
940 !
941 ELSE IF ( loop .GT. 1 ) THEN
942 !
943 !-----------------------------------------------------------------------
944
945 write(message,*)' assemble_output loop=',loop,' in IF block'
946 call wrf_message(message)
947
948 ! Open the boundary file.
949
950 IF ( loop .eq. 2 ) THEN
951 CALL construct_filename1( bdyname , 'wrfbdy' , grid%id , 2 )
952 CALL open_w_dataset ( id, TRIM(bdyname) , grid , config_flags , &
953 output_boundary , "DATASET=BOUNDARY", ierr )
954 IF ( ierr .NE. 0 ) THEN
955 CALL wrf_error_fatal( 'real: error opening wrfbdy for writing' )
956 ENDIF
957 ! grid%write_metadata = .true.
958 ELSE
959 ! what's this do?
960 ! grid%write_metadata = .true.
961 ! grid%write_metadata = .false.
962 CALL domain_clockadvance( grid )
963 END IF
964
965 !
966 !-----------------------------------------------------------------------
967 !*** SOUTHERN BOUNDARY
968 !-----------------------------------------------------------------------
969 !
970 IF(JPS==JDS)THEN
971 J=1
972 DO k = kps , MIN(kde,kpe)
973 DO i = ips , MIN(ide,ipe)
974 ubdy3dtemp2(i,k,j) = grid%nmm_u(i,k,j)
975 vbdy3dtemp2(i,k,j) = grid%nmm_v(i,k,j)
976 tbdy3dtemp2(i,k,j) = grid%nmm_t(i,k,j)
977 qbdy3dtemp2(i,k,j) = grid%nmm_q(i,k,j)
978 cwmbdy3dtemp2(i,k,j) = grid%nmm_cwm(i,k,j)
979 q2bdy3dtemp2(i,k,j) = grid%nmm_q2(i,k,j)
980 END DO
981 END DO
982 !
983 DO i = ips , MIN(ide,ipe)
984 pdbdy2dtemp2(i,1,j) = grid%nmm_pd(i,j)
985 END DO
986 ENDIF
987
988 !
989 !-----------------------------------------------------------------------
990 !*** NORTHERN BOUNDARY
991 !-----------------------------------------------------------------------
992 !
993 IF(JPE==JDE)THEN
994 J=MIN(JDE,JPE)
995 DO k = kps , MIN(kde,kpe)
996 DO i = ips , MIN(ide,ipe)
997 ubdy3dtemp2(i,k,j) = grid%nmm_u(i,k,j)
998 vbdy3dtemp2(i,k,j) = grid%nmm_v(i,k,j)
999 tbdy3dtemp2(i,k,j) = grid%nmm_t(i,k,j)
1000 qbdy3dtemp2(i,k,j) = grid%nmm_q(i,k,j)
1001 cwmbdy3dtemp2(i,k,j) = grid%nmm_cwm(i,k,j)
1002 q2bdy3dtemp2(i,k,j) = grid%nmm_q2(i,k,j)
1003 END DO
1004 END DO
1005
1006 DO i = ips , MIN(ide,ipe)
1007 pdbdy2dtemp2(i,1,j) = grid%nmm_pd(i,j)
1008 END DO
1009 ENDIF
1010 !
1011 !-----------------------------------------------------------------------
1012 !*** WESTERN BOUNDARY
1013 !-----------------------------------------------------------------------
1014 !
1015 IF(IPS==IDS)THEN
1016 I=1
1017 DO k = kps , MIN(kde,kpe)
1018 inc_h=mod(jps+1,2)
1019 if(k==1)then
1020 write(message,*)' assemble_ouput loop=',loop,' inc_h=',inc_h,' jps=',jps
1021 call wrf_debug(10,message)
1022 endif
1023 DO j = jps+inc_h, MIN(jde,jpe),2
1024 if (J .ge. 3 .and. J .le. jde-2 .and. mod(J,2) .eq. 1) then
1025 tbdy3dtemp2(i,k,j) = grid%nmm_t(i,k,j)
1026 if(k==1)then
1027 write(message,*)' loop=',loop,' i=',i,' j=',j,' tbdy3dtemp1(i,k,j)=',tbdy3dtemp1(i,k,j)
1028 call wrf_debug(10,message)
1029 endif
1030 qbdy3dtemp2(i,k,j) = grid%nmm_q(i,k,j)
1031 cwmbdy3dtemp2(i,k,j) = grid%nmm_cwm(i,k,j)
1032 q2bdy3dtemp2(i,k,j) = grid%nmm_q2(i,k,j)
1033 endif
1034 END DO
1035 END DO
1036 !
1037 DO k = kps , MIN(kde,kpe)
1038 inc_v=mod(jps,2)
1039 DO j = jps+inc_v, MIN(jde,jpe),2
1040 if (J .ge. 2 .and. J .le. jde-1 .and. mod(J,2) .eq. 0) then
1041 ubdy3dtemp2(i,k,j) = grid%nmm_u(i,k,j)
1042 vbdy3dtemp2(i,k,j) = grid%nmm_v(i,k,j)
1043 endif
1044 END DO
1045 END DO
1046
1047 inc_h=mod(jps+1,2)
1048 DO j = jps+inc_h, MIN(jde,jpe),2
1049 if (J .ge. 3 .and. J .le. jde-2 .and. mod(J,2) .eq. 1) then
1050 pdbdy2dtemp2(i,1,j) = grid%nmm_pd(i,j)
1051 write(message,*)' loop=',loop,' i=',i,' j=',j,' pdbdy2dtemp1(i,1,j)=',pdbdy2dtemp1(i,1,j)
1052 CALL wrf_debug(10,message)
1053 endif
1054 END DO
1055 ENDIF
1056 !
1057 !-----------------------------------------------------------------------
1058 !*** EASTERN BOUNDARY
1059 !-----------------------------------------------------------------------
1060 !
1061 IF(IPE==IDE)THEN
1062 I=MIN(IDE,IPE)
1063
1064 DO k = kps , MIN(kde,kpe)
1065 inc_h=mod(jps+1,2)
1066 DO j = jps+inc_h, MIN(jde,jpe),2
1067 if (J .ge. 3 .and. J .le. jde-2 .and. mod(J,2) .eq. 1) then
1068 tbdy3dtemp2(i,k,j) = grid%nmm_t(i,k,j)
1069 qbdy3dtemp2(i,k,j) = grid%nmm_q(i,k,j)
1070 cwmbdy3dtemp2(i,k,j) = grid%nmm_cwm(i,k,j)
1071 q2bdy3dtemp2(i,k,j) = grid%nmm_q2(i,k,j)
1072 endif
1073 END DO
1074 END DO
1075
1076 DO k = kps , MIN(kde,kpe)
1077 inc_v=mod(jps,2)
1078 DO j = jps+inc_v, MIN(jde,jpe),2
1079 if (J .ge. 2 .and. J .le. jde-1 .and. mod(J,2) .eq. 0) then
1080 ubdy3dtemp2(i,k,j) = grid%nmm_u(i,k,j)
1081 vbdy3dtemp2(i,k,j) = grid%nmm_v(i,k,j)
1082 endif
1083 END DO
1084 END DO
1085
1086 inc_h=mod(jps+1,2)
1087 DO j = jps+inc_h, MIN(jde,jpe),2
1088 if (J .ge. 3 .and. J .le. jde-2 .and. mod(J,2) .eq. 1) then
1089 pdbdy2dtemp2(i,1,j) = grid%nmm_pd(i,j)
1090 endif
1091 END DO
1092 ENDIF
1093 !-----------------------------------------------------------------------
1094 ! During all of the loops after the first loop,
1095 ! we first compute the boundary
1096 ! tendencies with the current data values
1097 ! (*bdy3dtemp2 arrays) and the previously
1098 ! saved information stored in the *bdy3dtemp1 arrays.
1099
1100
1101 CALL stuff_bdytend ( ubdy3dtemp2 , ubdy3dtemp1 , REAL(interval_seconds),&
1102 grid%nmm_u_bt , 'N' , &
1103 ijds , ijde , spec_bdy_width , &
1104 ids , ide+1 , jds , jde+1 , kds , kde+1 , &
1105 ims , ime , jms , jme , kms , kme , &
1106 ips , ipe , jps , jpe , kps , kpe+1 )
1107 CALL stuff_bdytend ( vbdy3dtemp2 , vbdy3dtemp1 , REAL(interval_seconds),&
1108 grid%nmm_v_bt , 'N' , &
1109 ijds , ijde , spec_bdy_width , &
1110 ids , ide+1 , jds , jde+1 , kds , kde+1 , &
1111 ims , ime , jms , jme , kms , kme , &
1112 ips , ipe , jps , jpe , kps , kpe+1 )
1113 CALL stuff_bdytend ( tbdy3dtemp2 , tbdy3dtemp1 , REAL(interval_seconds),&
1114 grid%nmm_t_bt , 'N' , &
1115 ijds , ijde , spec_bdy_width , &
1116 ids , ide+1 , jds , jde+1 , kds , kde+1 , &
1117 ims , ime , jms , jme , kms , kme , &
1118 ips , ipe , jps , jpe , kps , kpe+1 )
1119
1120 CALL stuff_bdytend ( cwmbdy3dtemp2,cwmbdy3dtemp1,REAL(interval_seconds),&
1121 grid%nmm_cwm_bt , 'N' , &
1122 ijds , ijde , 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 ( qbdy3dtemp2 , qbdy3dtemp1 , REAL(interval_seconds),&
1128 grid%nmm_q_bt , 'N' , &
1129 ijds , ijde , spec_bdy_width , &
1130 ids , ide+1 , jds , jde+1 , kds , kde+1 , &
1131 ims , ime , jms , jme , kms , kme , &
1132 ips , ipe , jps , jpe , kps , kpe+1 )
1133
1134 CALL stuff_bdytend ( q2bdy3dtemp2, q2bdy3dtemp1 , REAL(interval_seconds),&
1135 grid%nmm_q2_bt , 'N' , &
1136 ijds , ijde , spec_bdy_width , &
1137 ids , ide+1 , jds , jde+1 , kds , kde+1 , &
1138 ims , ime , jms , jme , kms , kme , &
1139 ips , ipe , jps , jpe , kps , kpe+1 )
1140
1141 CALL stuff_bdytend( pdbdy2dtemp2 , pdbdy2dtemp1, REAL(interval_seconds),&
1142 grid%nmm_pd_bt , 'M' , &
1143 ijds , ijde , spec_bdy_width , &
1144 ids , ide+1 , jds , jde+1 , 1 , 1 , &
1145 ims , ime , jms , jme , 1 , 1 , &
1146 ips , ipe , jps , jpe , 1 , 1 )
1147
1148 ! Both pieces of the boundary data are now
1149 ! available to be written (initial time and tendency).
1150 ! This looks ugly, these date shifting things.
1151 ! What's it for? We want the "Times" variable
1152 ! in the lateral BDY file to have the valid times
1153 ! of when the initial fields are written.
1154 ! That's what the loop-2 thingy is for with the start date.
1155 ! We increment the start_date so
1156 ! that the starting time in the attributes is the
1157 ! second time period. Why you may ask. I
1158 ! agree, why indeed.
1159
1160 temp24= current_date
1161 temp24b=start_date
1162 start_date = current_date
1163 CALL geth_newdate ( temp19 , temp24b(1:19) , &
1164 (loop-2) * model_config_rec%interval_seconds )
1165 current_date = temp19 // '.0000'
1166 CALL domain_clock_set( grid, current_date(1:19) )
1167 write(message,*) 'LBC valid between these times ',current_date, ' ',start_date
1168 CALL wrf_message(message)
1169
1170 CALL output_boundary ( id, grid , config_flags , ierr )
1171 current_date = temp24
1172 start_date = temp24b
1173
1174 ! OK, for all of the loops, we output the initialzation
1175 ! data, which would allow us to
1176 ! start the model at any of the available analysis time periods.
1177
1178 ! WRITE ( loop_char , FMT = '(I4.4)' ) loop
1179 ! CALL open_w_dataset ( id1, 'wrfinput'//loop_char , grid , config_flags , output_model_input , "DATASET=INPUT", ierr )
1180 ! IF ( ierr .NE. 0 ) THEN
1181 ! CALL wrf_error_fatal( 'real: error opening wrfinput'//loop_char//' for writing' )
1182 ! ENDIF
1183 ! grid%write_metadata = .true.
1184
1185 ! CALL calc_current_date ( grid%id , 0. )
1186 ! CALL output_model_input ( id1, grid , config_flags , ierr )
1187 ! CALL close_dataset ( id1 , config_flags , "DATASET=INPUT" )
1188
1189 ! Is this or is this not the last time time? We can remove some unnecessary
1190 ! stores if it is not.
1191
1192 IF ( loop .LT. time_loop_max ) THEN
1193
1194 ! We need to save the 3d data to compute a
1195 ! difference during the next loop. Couple the
1196 ! 3d fields with total mu (mub + mu_2) and the
1197 ! stagger-specific map scale factor.
1198 ! We load up the boundary data again for use in the next loop.
1199
1200
1201 !mp change these limits?????????
1202
1203 DO j = jps , jpe
1204 DO k = kps , kpe
1205 DO i = ips , ipe
1206 ubdy3dtemp1(i,k,j) = ubdy3dtemp2(i,k,j)
1207 vbdy3dtemp1(i,k,j) = vbdy3dtemp2(i,k,j)
1208 tbdy3dtemp1(i,k,j) = tbdy3dtemp2(i,k,j)
1209 cwmbdy3dtemp1(i,k,j) = cwmbdy3dtemp2(i,k,j)
1210 qbdy3dtemp1(i,k,j) = qbdy3dtemp2(i,k,j)
1211 q2bdy3dtemp1(i,k,j) = q2bdy3dtemp2(i,k,j)
1212 END DO
1213 END DO
1214 END DO
1215
1216 !mp change these limits?????????
1217
1218 DO j = jps , jpe
1219 DO i = ips , ipe
1220 pdbdy2dtemp1(i,1,j) = pdbdy2dtemp2(i,1,j)
1221 END DO
1222 END DO
1223
1224 ! There are 2 components to the lateral boundaries.
1225 ! First, there is the starting
1226 ! point of this time period - just the outer few rows and columns.
1227
1228
1229 CALL stuff_bdy ( ubdy3dtemp1 , grid%nmm_u_b , 'N' ,&
1230 ijds , ijde , spec_bdy_width , &
1231 ids , ide+1 , jds , jde+1 , kds , kde+1 , &
1232 ims , ime , jms , jme , kms , kme , &
1233 ips , ipe , jps , jpe , kps , kpe+1 )
1234 CALL stuff_bdy ( vbdy3dtemp1 , grid%nmm_v_b , 'N' , &
1235 ijds , ijde , spec_bdy_width , &
1236 ids , ide+1 , jds , jde+1 , kds , kde+1 , &
1237 ims , ime , jms , jme , kms , kme , &
1238 ips , ipe , jps , jpe , kps , kpe+1 )
1239 CALL stuff_bdy ( tbdy3dtemp1 , grid%nmm_t_b , 'N' , &
1240 ijds , ijde , spec_bdy_width , &
1241 ids , ide+1 , jds , jde+1 , kds , kde+1 , &
1242 ims , ime , jms , jme , kms , kme , &
1243 ips , ipe , jps , jpe , kps , kpe+1 )
1244
1245 CALL stuff_bdy ( cwmbdy3dtemp1 , grid%nmm_cwm_b , 'N' , &
1246 ijds , ijde , spec_bdy_width , &
1247 ids , ide+1 , jds , jde+1 , kds , kde+1 , &
1248 ims , ime , jms , jme , kms , kme , &
1249 ips , ipe , jps , jpe , kps , kpe+1 )
1250
1251 CALL stuff_bdy ( qbdy3dtemp1 , grid%nmm_q_b , 'N' ,&
1252 ijds , ijde , spec_bdy_width , &
1253 ids , ide+1 , jds , jde+1 , kds , kde+1 , &
1254 ims , ime , jms , jme , kms , kme , &
1255 ips , ipe , jps , jpe , kps , kpe+1 )
1256
1257 CALL stuff_bdy ( q2bdy3dtemp1 , grid%nmm_q2_b, 'N' ,&
1258 ijds , ijde , 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 ( pdbdy2dtemp1 , grid%nmm_pd_b , 'M' ,&
1264 ijds , ijde , spec_bdy_width , &
1265 ids , ide+1 , jds , jde+1 , 1 , 1 , &
1266 ims , ime , jms , jme , 1 , 1 , &
1267 ips , ipe , jps , jpe , 1 , 1 )
1268
1269 ELSE IF ( loop .EQ. time_loop_max ) THEN
1270
1271 ! If this is the last time through here, we need to close the files.
1272
1273 CALL close_dataset ( id , config_flags , "DATASET=BOUNDARY" )
1274
1275 END IF
1276
1277 END IF main_loop_test
1278
1279 END SUBROUTINE assemble_output