Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

real_nmm.F @ 3567

Last change on this file since 3567 was 2759, checked in by aslmd, 2 years ago
adding unmodified code from WRFV3.0.1.1, expurged from useless data +1M size
File size: 49.5 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format