Context Navigation

input_wrf.F.v3.6.1

Last change on this file was 593, checked in by lfita, 10 years ago
Adding version 3.6.1
File size: 80.4 KB

Line
1	!WRF:MEDIATION:IO
2	! ---principal wrf input routine (called from routines in module_io_domain )
3
4	SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
5	USE module_domain
6	USE module_state_description
7	USE module_configure
8	USE module_io
9	USE module_io_wrf
10	USE module_date_time
11	USE module_bc_time_utilities
12	USE module_utility
13	IMPLICIT NONE
14	#include <wrf_io_flags.h>
15	#include <wrf_status_codes.h>
16	TYPE(domain) :: grid
17	TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags
18	INTEGER, INTENT(IN) :: fid
19	INTEGER, INTENT(IN) :: switch
20	INTEGER, INTENT(INOUT) :: ierr
21
22	! Local data
23	INTEGER ids , ide , jds , jde , kds , kde , &
24	ims , ime , jms , jme , kms , kme , &
25	ips , ipe , jps , jpe , kps , kpe
26
27	TYPE( fieldlist ), POINTER :: p
28
29	INTEGER newswitch, itrace
30
31	INTEGER iname(9)
32	INTEGER iordering(3)
33	INTEGER icurrent_date(24)
34	INTEGER i,j,k
35	INTEGER icnt
36	INTEGER ndim
37	INTEGER ilen
38	INTEGER , DIMENSION(3) :: domain_start , domain_end
39	INTEGER , DIMENSION(3) :: memory_start , memory_end
40	INTEGER , DIMENSION(3) :: patch_start , patch_end
41	CHARACTER*256 errmess, currtimestr
42	CHARACTER*40 :: this_datestr, next_datestr
43	CHARACTER*9 NAMESTR
44	INTEGER IBDY, NAMELEN
45	LOGICAL wrf_dm_on_monitor
46	EXTERNAL wrf_dm_on_monitor
47	Type(WRFU_Time) time, currtime, currentTime
48	CHARACTER*19 new_date
49	CHARACTER*24 base_date
50	CHARACTER*80 fname
51	CHARACTER*80 dname, memord
52	LOGICAL dryrun
53	INTEGER idt
54	INTEGER itmp
55	INTEGER filestate, ierr3
56	INTEGER :: ide_compare , jde_compare , kde_compare
57	CHARACTER (len=19) simulation_start_date , first_date_input , first_date_nml
58	INTEGER first_date_start_year , &
59	first_date_start_month , &
60	first_date_start_day , &
61	first_date_start_hour , &
62	first_date_start_minute , &
63	first_date_start_second
64	INTEGER simulation_start_year , &
65	simulation_start_month , &
66	simulation_start_day , &
67	simulation_start_hour , &
68	simulation_start_minute , &
69	simulation_start_second
70	LOGICAL reset_simulation_start
71	REAL dx_compare , dy_compare , dum
72	INTEGER :: num_land_cat_compare
73	CHARACTER (LEN=256) :: MMINLU
74
75	! Local variables for vertical interpolation.
76
77	REAL, ALLOCATABLE, DIMENSION(: ) :: f_vint_1d
78	REAL, ALLOCATABLE, DIMENSION(:,:,: ) :: f_vint_3d
79	REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: f_vint_4d
80	integer :: ed1_c,em1_c,ep1_c
81	integer :: ed2_c,em2_c,ep2_c
82	integer :: n_ref_m,i_inter
83
84	! Local variables for the alarms in the input restart file.
85
86	INTEGER max_wrf_alarms_compare, seconds
87	CHARACTER*80 alarmname, timestr
88	TYPE(WRFU_Time) :: curtime, ringTime
89	TYPE(WRFU_TimeInterval) :: interval, interval2
90	integer s, iring
91
92	! Local variables: are we are using the correct hypsometric option for ARW ideal cases.
93
94	CHARACTER (LEN=80) :: input_name
95	LOGICAL :: this_is_an_ideal_run
96	INTEGER :: loop, hypsometric_opt
97
98	CHARACTER (LEN=256) :: a_message
99
100
101	!<DESCRIPTION>
102	!
103	! Core wrf input routine for all input data streams. Part of mediation layer.
104	!
105	! Note that WRF IOAPI routines wrf_get_dom_ti_*() do not return values during
106	! training reads (dryrun).
107	!
108	!</DESCRIPTION>
109
110	WRITE(wrf_err_message,*)'input_wrf: begin, fid = ',fid
111	CALL wrf_debug( 300 , wrf_err_message )
112
113	CALL modify_io_masks ( grid%id ) ! this adjusts the I/O masks according to the users run-time specs, if any
114
115	ierr = 0
116
117	CALL get_ijk_from_grid ( grid , &
118	ids, ide, jds, jde, kds, kde, &
119	ims, ime, jms, jme, kms, kme, &
120	ips, ipe, jps, jpe, kps, kpe )
121
122	! If this was not a training read (dry run) check for erroneous values.
123	CALL wrf_inquire_filename ( fid , fname , filestate , ierr )
124	IF ( ierr /= 0 ) THEN
125	WRITE(wrf_err_message,*)'module_io_wrf: input_wrf: wrf_inquire_filename Status = ',ierr
126	CALL wrf_error_fatal( wrf_err_message )
127	ENDIF
128
129	WRITE(wrf_err_message,*)'input_wrf: fid,filestate = ',fid,filestate
130	CALL wrf_debug( 300 , wrf_err_message )
131
132	dryrun = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED )
133
134	WRITE(wrf_err_message,*)'input_wrf: dryrun = ',dryrun,' switch ',switch
135	CALL wrf_debug( 300 , wrf_err_message )
136
137	check_if_dryrun : IF ( .NOT. dryrun ) THEN
138
139	#if (EM_CORE == 1)
140	IF ( switch .EQ. input_only ) THEN
141
142	! Make sure for ARW ideal cases that the hypsometric option, the
143	! way that we integrate the heigh field, is set to 1. This is the
144	! method that is used in all of the "ideal" programs to get the
145	! base-state height (phb).
146
147	CALL wrf_get_dom_ti_char ( fid , 'TITLE' , input_name , ierr )
148	grid%this_is_an_ideal_run = INDEX(TRIM(input_name) , 'IDEAL' ) .NE. 0
149	IF ( grid%this_is_an_ideal_run ) THEN
150	grid%hypsometric_opt = 1
151	config_flags%hypsometric_opt = 1
152	DO loop = 1 , grid%max_dom
153	CALL nl_set_hypsometric_opt ( loop , 1 )
154	END DO
155	WRITE(wrf_err_message,*)'Ideal cases do not support the hypsometric option.'
156	CALL wrf_debug( 0 , wrf_err_message )
157	END IF
158	END IF
159	#endif
160
161	! INPUT ONLY (KK)
162
163	IF ( switch .EQ. restart_only ) THEN
164
165	! recover the restart alarms from input if available
166
167	CALL wrf_get_dom_ti_integer( fid , 'MAX_WRF_ALARMS', max_wrf_alarms_compare, 1, icnt, ierr )
168	IF ( max_wrf_alarms_compare .NE. MAX_WRF_ALARMS ) THEN
169	WRITE(wrf_err_message,*)'MAX_WRF_ALARMS different in restart file (',max_wrf_alarms_compare,&
170	') from in code (',MAX_WRF_ALARMS,'). Disregarding info in restart file.'
171	ELSE
172	curtime = domain_get_current_time( grid )
173	DO i = auxinput1_only, MAX_WRF_ALARMS
174	IF ( grid%alarms_created(i) .AND. .NOT. i .EQ. boundary_only ) THEN
175	write(alarmname,'("WRF_ALARM_ISRINGING_",i2.2)')i
176	CALL wrf_get_dom_ti_integer( fid, TRIM(alarmname), iring, 1, icnt, ierr )
177
178	write(alarmname,'("WRF_ALARM_SECS_TIL_NEXT_RING_",i2.2)')i
179	CALL wrf_get_dom_ti_integer( fid, TRIM(alarmname), seconds, 1, icnt, ierr )
180	IF ( ierr .EQ. 0 &
181	.AND. seconds .GE. 0 ) THEN ! disallow negative intervals; can happen with wrfbdy datasets
182	! which keep time differently
183
184	! Get and set interval so that we are sure to have both the
185	! interval and first ring time set correctly
186	CALL WRFU_AlarmGet( grid%alarms(i), ringinterval=interval2 )
187
188	IF (config_flags%override_restart_timers) THEN
189	IF (i .EQ. restart_only) THEN
190	seconds = grid%restart_interval_d * 86400 + &
191	grid%restart_interval_h * 3600 + &
192	grid%restart_interval_m * 60 + &
193	grid%restart_interval * 60 + &
194	grid%restart_interval_s
195	ENDIF
196	ENDIF
197
198	CALL WRFU_TimeIntervalSet(interval,S=seconds)
199	ringTime = curtime + interval
200	CALL WRFU_AlarmSet( grid%alarms(i), RingInterval=interval2, RingTime=ringTime )
201
202	ENDIF
203
204	IF ( iring .EQ. 1 ) THEN
205	CALL WRFU_AlarmRingerOn( grid%alarms( i ) )
206	ELSE
207	CALL WRFU_AlarmRingerOff( grid%alarms( i ) )
208	ENDIF
209	ENDIF
210	ENDDO
211	ENDIF
212
213
214	!OUTPUT ONLY (KK)
215
216	IF ( switch .EQ. restart_only .AND. .NOT. config_flags%override_restart_timers ) THEN
217
218	! recover the restart alarms from input if available
219
220	CALL wrf_get_dom_ti_integer( fid , 'MAX_WRF_ALARMS', max_wrf_alarms_compare, 1, icnt, ierr )
221	IF ( max_wrf_alarms_compare .NE. MAX_WRF_ALARMS ) THEN
222	WRITE(wrf_err_message,*)'MAX_WRF_ALARMS different in restart file (',max_wrf_alarms_compare,&
223	') from in code (',MAX_WRF_ALARMS,'). Disregarding info in restart file.'
224	ELSE
225	curtime = domain_get_current_time( grid )
226	DO i = 1, auxinput1_only-1
227	IF ( grid%alarms_created(i) .AND. .NOT. i .EQ. boundary_only ) THEN
228	write(alarmname,'("WRF_ALARM_ISRINGING_",i2.2)')i
229	CALL wrf_get_dom_ti_integer( fid, TRIM(alarmname), iring, 1, icnt, ierr )
230
231	write(alarmname,'("WRF_ALARM_SECS_TIL_NEXT_RING_",i2.2)')i
232	CALL wrf_get_dom_ti_integer( fid, TRIM(alarmname), seconds, 1, icnt, ierr )
233	IF ( ierr .EQ. 0 &
234	.AND. seconds .GE. 0 ) THEN ! disallow negative intervals; can happen with wrfbdy datasets
235	! which keep time differently
236
237	! Get and set interval so that we are sure to have both the
238	! interval and first ring time set correctly
239	CALL WRFU_AlarmGet( grid%alarms(i), ringinterval=interval2 )
240
241	IF (config_flags%override_restart_timers) THEN
242	IF (i .EQ. history_only) THEN
243	seconds = grid%history_interval_d * 86400 + &
244	grid%history_interval_h * 3600 + &
245	grid%history_interval_m * 60 + &
246	grid%history_interval * 60 + &
247	grid%history_interval_s
248	ENDIF
249	ENDIF
250
251	CALL WRFU_TimeIntervalSet(interval,S=seconds)
252	ringTime = curtime + interval
253	CALL WRFU_AlarmSet( grid%alarms(i), RingInterval=interval, RingTime=ringTime )
254
255	ENDIF
256
257	IF ( iring .EQ. 1 ) THEN
258	CALL WRFU_AlarmRingerOn( grid%alarms( i ) )
259	ELSE
260	CALL WRFU_AlarmRingerOff( grid%alarms( i ) )
261	ENDIF
262	ENDIF
263	ENDDO
264	ENDIF
265
266	ENDIF
267
268	CALL wrf_get_dom_ti_char ( fid , 'SIMULATION_START_DATE' , simulation_start_date , ierr )
269	CALL nl_get_reset_simulation_start ( 1, reset_simulation_start )
270	IF ( ( ierr .EQ. 0 ) .AND. ( .NOT. reset_simulation_start ) ) THEN
271	! Overwrite simulation start date with metadata.
272	#ifdef PLANET
273	READ ( simulation_start_date , fmt = '(I4,1x,I5,1x,I2,1x,I2,1x,I2)' ) &
274	simulation_start_year, &
275	simulation_start_day, simulation_start_hour, &
276	simulation_start_minute, simulation_start_second
277	simulation_start_month = 0
278	#else
279	READ ( simulation_start_date , fmt = '(I4,1x,I2,1x,I2,1x,I2,1x,I2,1x,I2)' ) &
280	simulation_start_year, simulation_start_month, &
281	simulation_start_day, simulation_start_hour, &
282	simulation_start_minute, simulation_start_second
283	#endif
284	CALL nl_set_simulation_start_year ( 1 , simulation_start_year )
285	CALL nl_set_simulation_start_month ( 1 , simulation_start_month )
286	CALL nl_set_simulation_start_day ( 1 , simulation_start_day )
287	CALL nl_set_simulation_start_hour ( 1 , simulation_start_hour )
288	CALL nl_set_simulation_start_minute ( 1 , simulation_start_minute )
289	CALL nl_set_simulation_start_second ( 1 , simulation_start_second )
290	IF ( switch .EQ. input_only ) THEN
291	WRITE(wrf_err_message,*)fid,' input_wrf, input_only: SIMULATION_START_DATE = ', &
292	simulation_start_date(1:19)
293	CALL wrf_debug ( 300 , TRIM(wrf_err_message ) )
294	ELSE IF ( switch .EQ. restart_only ) THEN
295	WRITE(wrf_err_message,*)fid,' input_wrf, restart_only: SIMULATION_START_DATE = ', &
296	simulation_start_date(1:19)
297	CALL wrf_debug ( 300 , TRIM(wrf_err_message ) )
298	ENDIF
299	ELSE
300	CALL nl_get_start_year ( 1 , simulation_start_year )
301	CALL nl_get_start_month ( 1 , simulation_start_month )
302	CALL nl_get_start_day ( 1 , simulation_start_day )
303	CALL nl_get_start_hour ( 1 , simulation_start_hour )
304	CALL nl_get_start_minute ( 1 , simulation_start_minute )
305	CALL nl_get_start_second ( 1 , simulation_start_second )
306	CALL nl_set_simulation_start_year ( 1 , simulation_start_year )
307	CALL nl_set_simulation_start_month ( 1 , simulation_start_month )
308	CALL nl_set_simulation_start_day ( 1 , simulation_start_day )
309	CALL nl_set_simulation_start_hour ( 1 , simulation_start_hour )
310	CALL nl_set_simulation_start_minute ( 1 , simulation_start_minute )
311	CALL nl_set_simulation_start_second ( 1 , simulation_start_second )
312	IF ( reset_simulation_start ) THEN
313	CALL wrf_message('input_wrf: forcing SIMULATION_START_DATE = head_grid start time')
314	CALL wrf_message(' due to namelist variable reset_simulation_start')
315	ELSE
316	CALL wrf_message('input_wrf: SIMULATION_START_DATE not available in input')
317	CALL wrf_message('will use head_grid start time from namelist')
318	ENDIF
319	ENDIF
320	! Initialize derived time quantity in grid%xtime.
321	! Note that this call is also made in setup_timekeeping().
322	! Ugh, what a hack. Simplify all this later...
323	CALL domain_clock_get( grid, minutesSinceSimulationStart=grid%xtime )
324	! Note that it is NOT necessary to reset grid%julian here.
325	WRITE(wrf_err_message,*) 'input_wrf: set xtime to ',grid%xtime
326	CALL wrf_debug ( 100, TRIM(wrf_err_message) )
327	ELSE IF ( switch .EQ. auxinput1_only ) then
328	CALL wrf_get_dom_ti_char ( fid , 'SIMULATION_START_DATE' , first_date_input , ierr )
329	WRITE(wrf_err_message,*)'metgrid input_wrf.F first_date_input = ',first_date_input
330	CALL wrf_message(wrf_err_message)
331	CALL nl_get_start_year ( 1 , first_date_start_year )
332	CALL nl_get_start_month ( 1 , first_date_start_month )
333	CALL nl_get_start_day ( 1 , first_date_start_day )
334	CALL nl_get_start_hour ( 1 , first_date_start_hour )
335	CALL nl_get_start_minute ( 1 , first_date_start_minute )
336	CALL nl_get_start_second ( 1 , first_date_start_second )
337	WRITE ( first_date_nml, fmt = '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) &
338	first_date_start_year, first_date_start_month, &
339	first_date_start_day, first_date_start_hour, &
340	first_date_start_minute, first_date_start_second
341	WRITE (wrf_err_message,*) 'metgrid input_wrf.F first_date_nml = ',first_date_nml
342	CALL wrf_message( TRIM(wrf_err_message ) )
343	ENDIF
344
345	! Test to make sure that the input data is the right size. Do this for input from real/ideal into
346	! WRF, and from the standard initialization into real.
347
348	IF ( ( switch .EQ. input_only ) .OR. &
349	( switch .EQ. auxinput1_only ) ) THEN
350	ierr = 0
351	CALL wrf_get_dom_ti_integer ( fid , 'WEST-EAST_GRID_DIMENSION' , ide_compare , 1 , icnt , ierr3 )
352	ierr = max( ierr, ierr3 )
353	CALL wrf_get_dom_ti_integer ( fid , 'SOUTH-NORTH_GRID_DIMENSION' , jde_compare , 1 , icnt , ierr3 )
354	ierr = max( ierr, ierr3 )
355	CALL wrf_get_dom_ti_integer ( fid , 'BOTTOM-TOP_GRID_DIMENSION' , kde_compare , 1 , icnt , ierr3 )
356	ierr = max( ierr, ierr3 )
357	IF ( ierr3 .NE. 0 ) CALL wrf_error_fatal( 'wrf_get_dom_ti_integer getting dimension information from dataset' )
358
359	#if (EM_CORE == 1)
360
361	IF ( ( switch .EQ. input_only ) .AND. ( config_flags%io_form_input .EQ. 2 ) ) THEN
362
363	! For backward compatibility. If we do not find the hypsometric_opt defined
364	! in the input data, this is pre version 3.4. Most likely, the hypsometric_opt
365	! was the default value, 1.
366
367	hypsometric_opt = -1
368	CALL wrf_get_dom_ti_integer ( fid , 'HYPSOMETRIC_OPT' , hypsometric_opt , 1 , icnt , ierr )
369	IF ( ( hypsometric_opt .NE. 1 ) .AND. ( hypsometric_opt .NE. 2 ) ) THEN
370	grid%hypsometric_opt = 1
371	config_flags%hypsometric_opt = 1
372	DO loop = 1 , grid%max_dom
373	CALL nl_set_hypsometric_opt ( loop , 1 )
374	END DO
375	WRITE(wrf_err_message,*)'Resetting the hypsometric_opt from default value of 2 to 1'
376	CALL wrf_debug( 0 , wrf_err_message )
377	END IF
378	END IF
379
380	! Test to make sure that the grid distances are the right size.
381
382	CALL wrf_get_dom_ti_real ( fid , 'DX' , dx_compare , 1 , icnt , ierr )
383	CALL wrf_get_dom_ti_real ( fid , 'DY' , dy_compare , 1 , icnt , ierr )
384	IF ( ( ABS ( dx_compare - config_flags%dx ) .GT. 1.E-5 * dx_compare ) .OR. &
385	( ABS ( dy_compare - config_flags%dy ) .GT. 1.E-5 * dy_compare ) ) THEN
386	IF ( ( config_flags%polar ) .AND. ( config_flags%grid_id .EQ. 1 ) ) THEN
387	WRITE(wrf_err_message,*)'input_wrf: DX and DY from input file expected to be wrong'
388	CALL wrf_debug ( 1 , wrf_err_message )
389	ELSE
390	WRITE(wrf_err_message,*)'dx and dy from file ',dx_compare,dy_compare
391	CALL wrf_message(wrf_err_message)
392	WRITE(wrf_err_message,*)'dx and dy from namelist ',config_flags%dx,config_flags%dy
393	CALL wrf_message(wrf_err_message)
394	CALL wrf_error_fatal( 'DX and DY do not match comparing namelist to the input file' )
395	END IF
396	END IF
397	#endif
398	END IF
399
400	#if (EM_CORE == 1)
401	IF ( ( switch .EQ. input_only ) .OR. ( switch .EQ. auxinput2_only ) .OR. ( switch .EQ. auxinput1_only ) ) THEN
402	ierr = 0
403	ierr3 = 0
404	IF ( ( ( switch .EQ. input_only ) .AND. ( grid%id .GE. 2 ) ) .OR. ( switch .EQ. auxinput2_only ) ) THEN
405	CALL wrf_get_dom_ti_integer ( fid , 'I_PARENT_START' , itmp , 1 , icnt , ierr3 )
406	ELSE IF ( ( switch .EQ. auxinput1_only ) .AND. ( grid%id .GE. 2 ) ) THEN
407	CALL wrf_get_dom_ti_integer ( fid , 'i_parent_start' , itmp , 1 , icnt , ierr3 )
408	ELSE IF ( ( ( switch .EQ. auxinput1_only ) .OR. ( switch .EQ. input_only ) ) .AND. ( grid%id .EQ. 1 ) ) THEN
409	itmp = config_flags%i_parent_start
410	ierr3 = 0
411	END IF
412	ierr = max( ierr, ierr3 )
413	IF ( itmp .NE. config_flags%i_parent_start ) THEN
414	ierr = 1
415	WRITE(wrf_err_message,*)'i_parent_start from namelist.input file = ',config_flags%i_parent_start
416	CALL wrf_message(wrf_err_message)
417	WRITE(wrf_err_message,*)'i_parent_start from gridded input file = ',itmp
418	CALL wrf_message(wrf_err_message)
419	END IF
420	IF ( ( ( switch .EQ. input_only ) .AND. ( grid%id .GE. 2 ) ) .OR. ( switch .EQ. auxinput2_only ) ) THEN
421	CALL wrf_get_dom_ti_integer ( fid , 'J_PARENT_START' , itmp , 1 , icnt , ierr3 )
422	ELSE IF ( ( switch .EQ. auxinput1_only ) .AND. ( grid%id .GE. 2 ) ) THEN
423	CALL wrf_get_dom_ti_integer ( fid , 'j_parent_start' , itmp , 1 , icnt , ierr3 )
424	ELSE IF ( ( ( switch .EQ. auxinput1_only ) .OR. ( switch .EQ. input_only ) ) .AND. ( grid%id .EQ. 1 ) ) THEN
425	itmp = config_flags%j_parent_start
426	ierr3 = 0
427	END IF
428	ierr = max( ierr, ierr3 )
429	IF ( itmp .NE. config_flags%j_parent_start ) THEN
430	ierr = 1
431	WRITE(wrf_err_message,*)'j_parent_start from namelist.input file = ',config_flags%j_parent_start
432	CALL wrf_message(wrf_err_message)
433	WRITE(wrf_err_message,*)'j_parent_start from gridded input file = ',itmp
434	CALL wrf_message(wrf_err_message)
435	END IF
436	IF ( ierr .NE. 0 ) THEN
437	CALL wrf_error_fatal( 'Nest start locations do not match: namelist.input vs gridded input file' )
438	END IF
439	END IF
440	#endif
441
442	! do the check later (see check_if_dryrun below)
443
444	! We do not want the CEN_LAT LON values from the boundary file. For 1-way nests
445	! with ndown, this ends up being the data from the previous coarse domain.
446
447	IF ( switch .NE. boundary_only ) THEN
448	CALL wrf_get_dom_ti_real ( fid , 'CEN_LAT' , config_flags%cen_lat , 1 , icnt , ierr )
449	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for CEN_LAT returns ',config_flags%cen_lat
450	CALL wrf_debug ( 300 , wrf_err_message )
451	CALL nl_set_cen_lat ( grid%id , config_flags%cen_lat )
452
453	CALL wrf_get_dom_ti_real ( fid , 'CEN_LON' , config_flags%cen_lon , 1 , icnt , ierr )
454	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for CEN_LON returns ',config_flags%cen_lon
455	CALL wrf_debug ( 300 , wrf_err_message )
456	CALL nl_set_cen_lon ( grid%id , config_flags%cen_lon )
457	ELSE
458	CALL wrf_get_dom_ti_real ( fid , 'CEN_LAT' , dum , 1 , icnt , ierr )
459	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for CEN_LAT returns ',dum
460	CALL wrf_debug ( 300 , wrf_err_message )
461
462	CALL wrf_get_dom_ti_real ( fid , 'CEN_LON' , dum , 1 , icnt , ierr )
463	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for CEN_LON returns ',dum
464	CALL wrf_debug ( 300 , wrf_err_message )
465	END IF
466
467	CALL wrf_get_dom_ti_real ( fid , 'TRUELAT1' , config_flags%truelat1 , 1 , icnt , ierr )
468	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for TRUELAT1 returns ',config_flags%truelat1
469	CALL wrf_debug ( 300 , wrf_err_message )
470	CALL nl_set_truelat1 ( grid%id , config_flags%truelat1 )
471
472	CALL wrf_get_dom_ti_real ( fid , 'TRUELAT2' , config_flags%truelat2 , 1 , icnt , ierr )
473	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for TRUELAT2 returns ',config_flags%truelat2
474	CALL wrf_debug ( 300 , wrf_err_message )
475	CALL nl_set_truelat2 ( grid%id , config_flags%truelat2 )
476
477	CALL wrf_get_dom_ti_real ( fid , 'MOAD_CEN_LAT' , config_flags%moad_cen_lat , 1 , icnt , ierr )
478	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for MOAD_CEN_LAT returns ',config_flags%moad_cen_lat
479	CALL wrf_debug ( 300 , wrf_err_message )
480	CALL nl_set_moad_cen_lat ( grid%id , config_flags%moad_cen_lat )
481
482	CALL wrf_get_dom_ti_real ( fid , 'STAND_LON' , config_flags%stand_lon , 1 , icnt , ierr )
483	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for STAND_LON returns ',config_flags%stand_lon
484	CALL wrf_debug ( 300 , wrf_err_message )
485	CALL nl_set_stand_lon ( grid%id , config_flags%stand_lon )
486
487	#if ( NMM_CORE != 1 )
488
489	CALL wrf_get_dom_ti_real ( fid , 'POLE_LAT' , config_flags%pole_lat , 1 , icnt , ierr )
490	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for POLE_LAT returns ',config_flags%pole_lat
491	CALL wrf_debug ( 300 , wrf_err_message )
492	CALL nl_set_pole_lat ( grid%id , config_flags%pole_lat )
493
494	CALL wrf_get_dom_ti_real ( fid , 'POLE_LON' , config_flags%pole_lon , 1 , icnt , ierr )
495	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for POLE_LON returns ',config_flags%pole_lon
496	CALL wrf_debug ( 300 , wrf_err_message )
497	CALL nl_set_pole_lon ( grid%id , config_flags%pole_lon )
498
499	! program_name is defined in module_domain and set in the main program for whatever application
500	! is using subroutine input_wrf (that is, the subroutine you are looking at here). Data files
501	! written by SI have P_TOP as a metadata item; the real program and wrf model have it as a
502	! state variable. This test is to supress non-fatal but confusing messages from the model complaining
503	! that P_TOP cannot be read from the metadata for this dataset. JM 20040905
504	!
505	! Note, P_TOP is not defined in the NMM core.
506
507	IF ( program_name(1:7) .EQ. "REAL_EM" ) THEN
508	CALL wrf_get_dom_ti_real ( fid , 'P_TOP' , grid%p_top , 1 , icnt , ierr )
509	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for P_TOP returns ',grid%p_top
510	CALL wrf_debug ( 300 , wrf_err_message )
511	ENDIF
512	#endif
513
514	IF ( switch .NE. boundary_only ) THEN
515	CALL wrf_get_dom_ti_real ( fid , 'GMT' , config_flags%gmt , 1 , icnt , ierr )
516	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for GMT returns ',config_flags%gmt
517	CALL wrf_debug ( 300 , wrf_err_message )
518	CALL nl_set_gmt ( grid%id , config_flags%gmt )
519
520	CALL wrf_get_dom_ti_integer ( fid , 'JULYR' , config_flags%julyr , 1 , icnt , ierr )
521	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for JULYR returns ',config_flags%julyr
522	CALL wrf_debug ( 300 , wrf_err_message )
523	CALL nl_set_julyr ( grid%id , config_flags%julyr )
524
525	CALL wrf_get_dom_ti_integer ( fid , 'JULDAY' , config_flags%julday , 1 , icnt , ierr )
526	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for JULDAY returns ',config_flags%julday
527	CALL wrf_debug ( 300 , wrf_err_message )
528	CALL nl_set_julday ( grid%id , config_flags%julday )
529	ENDIF
530
531	CALL wrf_get_dom_ti_integer ( fid , 'MAP_PROJ' , config_flags%map_proj , 1 , icnt , ierr )
532	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for MAP_PROJ returns ',config_flags%map_proj
533	CALL wrf_debug ( 300 , wrf_err_message )
534	CALL nl_set_map_proj ( grid%id , config_flags%map_proj )
535	grid%map_proj = config_flags%map_proj
536
537	CALL wrf_get_dom_ti_char ( fid , 'MMINLU', mminlu , ierr )
538	IF ( ierr .NE. 0 ) THEN
539	WRITE(wrf_err_message,*)'MMINLU error on input'
540	mminlu = " "
541	CALL wrf_debug ( 0 , wrf_err_message )
542	ELSE IF ( ( ( mminlu(1:1) .GE. "A" ) .AND. ( mminlu(1:1) .LE. "Z" ) ) .OR. &
543	( ( mminlu(1:1) .GE. "a" ) .AND. ( mminlu(1:1) .LE. "z" ) ) .OR. &
544	( ( mminlu(1:1) .GE. "0" ) .AND. ( mminlu(1:1) .LE. "9" ) ) ) THEN
545	! no-op, the mminlu field is probably OK
546	ELSE IF ( mminlu(1:1) .EQ. " " ) THEN
547	mminlu = " "
548	ELSE
549	mminlu = " "
550	END IF
551	call wrf_debug( 1 , "mminlu = '" // TRIM(mminlu) // "'")
552	if (index(mminlu, char(0)) > 0) mminlu(index(mminlu, char(0)):) = " "
553	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_char for MMINLU returns ' // TRIM(mminlu)
554	CALL wrf_debug ( 300 , wrf_err_message )
555	CALL nl_set_mminlu ( grid%id, mminlu )
556
557	! Test to make sure that the number of land categories is set correctly
558	! The default is set to 24 somewhere, from the number of categories
559	! in the traditional USGS dataset
560
561	IF ( ( switch .EQ. input_only ) .OR. &
562	( switch .EQ. auxinput1_only ) .OR. &
563	( switch .EQ. auxinput2_only ) ) THEN
564	call wrf_get_dom_ti_integer(fid, "NUM_LAND_CAT", num_land_cat_compare, 1, icnt, ierr)
565	if ( (ierr .NE. 0) .OR. ( num_land_cat_compare .LT. 1 ) .OR. ( num_land_cat_compare .GT. 1000 ) ) then
566	IF (mminlu == 'MODIFIED_IGBP_MODIS_NOAH') THEN
567	call wrf_debug( 1 , "Must be old WPS data, assuming 20 levels for NUM_LAND_CAT")
568	num_land_cat_compare = 20
569	ELSE
570	call wrf_debug( 1 , "Must be old WPS data, assuming 24 levels for NUM_LAND_CAT")
571	num_land_cat_compare = 24
572	END IF
573	endif
574	if ( config_flags%num_land_cat /= num_land_cat_compare ) then
575	call wrf_message("----------------- ERROR -------------------")
576	WRITE(wrf_err_message,'("namelist : NUM_LAND_CAT = ",I10)') config_flags%num_land_cat
577	call wrf_message(wrf_err_message)
578	WRITE(wrf_err_message,'("input files : NUM_LAND_CAT = ",I10, " (from geogrid selections).")') num_land_cat_compare
579	call wrf_message(wrf_err_message)
580	call wrf_error_fatal("Mismatch between namelist and wrf input files for dimension NUM_LAND_CAT")
581	endif
582	ENDIF
583
584	! Test here to check that config_flags%num_metgrid_soil_levels in namelist
585	! is equal to what is in the global attributes of the met_em files. Note that
586	! if this is not the first time period, we don't really care about soil data.
587
588	IF ( ( switch .EQ. auxinput1_only ) .AND. &
589	( first_date_nml .EQ. first_date_input ) ) THEN
590	CALL wrf_get_dom_ti_integer ( fid, 'NUM_METGRID_SOIL_LEVELS', itmp, 1, icnt, ierr )
591
592	IF ( ierr .EQ. 0 ) THEN
593
594	#if (EM_CORE == 1)
595	IF ( itmp .EQ. 1 ) THEN
596	call wrf_error_fatal("NUM_METGRID_SOIL_LEVELS must be greater than 1")
597	END IF
598	#endif
599	WRITE(wrf_err_message,*)'input_wrf: global attribute NUM_METGRID_SOIL_LEVELS returns ', itmp
600	CALL wrf_debug ( 300 , wrf_err_message )
601	IF ( config_flags%num_metgrid_soil_levels /= itmp ) THEN
602	call wrf_message("----------------- ERROR -------------------")
603	WRITE(wrf_err_message,'("namelist : num_metgrid_soil_levels = ",I10)') config_flags%num_metgrid_soil_levels
604	call wrf_message(wrf_err_message)
605	#if (EM_CORE == 1)
606	WRITE(wrf_err_message,'("input files : NUM_METGRID_SOIL_LEVELS = ",I10, " (from met_em files).")') itmp
607	#else
608	WRITE(wrf_err_message,'("input files : NUM_METGRID_SOIL_LEVELS = ",I10, " (from met_nmm files).")') itmp
609	#endif
610	call wrf_message(wrf_err_message)
611	call wrf_error_fatal("Mismatch between namelist and global attribute NUM_METGRID_SOIL_LEVELS")
612	END IF
613	END IF
614	END IF
615
616	#if 0
617	#if ( WRF_CHEM == 1 )
618	! Dust erosion static data.
619
620	CALL wrf_get_dom_ti_integer ( fid, 'EROSION_DIM', itmp, 1, icnt, ierr )
621
622	IF ( ierr .EQ. 0 ) THEN
623	WRITE(wrf_err_message,*)'input_wrf: global attribute EROSION_DIM returns ', itmp
624	CALL wrf_debug ( 300 , wrf_err_message )
625	IF ( config_flags%erosion_dim /= itmp ) THEN
626	call wrf_message("----------------- ERROR -------------------")
627	WRITE(wrf_err_message,'("namelist : erosion_dim = ",I10)') config_flags%erosion_dim
628	call wrf_message(wrf_err_message)
629	WRITE(wrf_err_message,'("input files : EROSION_DIM = ",I10, " (from met_em files).")') itmp
630	call wrf_message(wrf_err_message)
631	call wrf_error_fatal("Mismatch between namelist and global attribute EROSION_DIM")
632	END IF
633	END IF
634	#endif
635	#endif
636
637	! Test here to check that config_flags%sf_surface_physics in namelist
638	! is equal to what is in the global attributes of the wrfinput files
639
640	IF ( switch .EQ. input_only ) THEN
641	CALL wrf_get_dom_ti_integer ( fid, 'SF_SURFACE_PHYSICS', itmp, 1, icnt, ierr )
642	IF ( ierr .EQ. 0 ) THEN
643	WRITE(wrf_err_message,*)'input_wrf: global attribute SF_SURFACE_PHYSICS returns ', itmp
644	CALL wrf_debug ( 300 , wrf_err_message )
645	IF ( config_flags%sf_surface_physics /= itmp ) THEN
646	IF ( ( config_flags%sf_surface_physics == LSMSCHEME ) .and. ( itmp == NOAHMPSCHEME ) ) then
647	! All is well. Noah-MP and Noah have compatible wrfinput files.
648	ELSE IF ( ( config_flags%sf_surface_physics == NOAHMPSCHEME ) .and. ( itmp == LSMSCHEME ) ) then
649	! All is well. Noah-MP and Noah have compatible wrfinput files.
650	ELSE
651	call wrf_message("----------------- ERROR -------------------")
652	WRITE(wrf_err_message,'("namelist : sf_surface_physics = ",I10)') config_flags%sf_surface_physics
653	call wrf_message(wrf_err_message)
654	WRITE(wrf_err_message,'("input files : SF_SURFACE_PHYSICS = ",I10, " (from wrfinput files).")') itmp
655	call wrf_message(wrf_err_message)
656	call wrf_error_fatal("Mismatch between namelist and global attribute SF_SURFACE_PHYSICS")
657	END IF
658	END IF
659	END IF
660	END IF
661
662
663	CALL wrf_get_dom_ti_integer ( fid , 'ISWATER' , config_flags%iswater , 1 , icnt , ierr )
664	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for ISWATER returns ',config_flags%iswater
665	CALL wrf_debug ( 300 , wrf_err_message )
666	IF ( ierr .NE. 0 ) THEN
667	IF (mminlu == 'UMD') THEN
668	config_flags%iswater = 14
669	ELSE IF (mminlu == 'MODIFIED_IGBP_MODIS_NOAH') THEN
670	config_flags%iswater = 17
671	ELSE
672	config_flags%iswater = 16
673	ENDIF
674	ENDIF
675	CALL nl_set_iswater ( grid%id , config_flags%iswater )
676	grid%iswater = config_flags%iswater
677
678	CALL wrf_get_dom_ti_integer ( fid , 'ISLAKE' , config_flags%islake , 1 , icnt , ierr )
679	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for ISLAKE returns ',config_flags%islake
680	CALL wrf_debug ( 300 , wrf_err_message )
681	IF ( ierr .NE. 0 ) THEN
682	config_flags%islake = -1
683	ENDIF
684	CALL nl_set_islake ( grid%id , config_flags%islake )
685	grid%islake = config_flags%islake
686
687	CALL wrf_get_dom_ti_integer ( fid , 'ISICE' , config_flags%isice , 1 , icnt , ierr )
688	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for ISICE returns ',config_flags%isice
689	CALL wrf_debug ( 300 , wrf_err_message )
690	IF ( ierr .NE. 0 ) THEN
691	IF (mminlu == 'UMD') THEN
692	config_flags%isice = 14
693	ELSE IF (mminlu == 'MODIFIED_IGBP_MODIS_NOAH') THEN
694	config_flags%isice = 15
695	ELSE
696	config_flags%isice = 24
697	ENDIF
698	ENDIF
699	CALL nl_set_isice ( grid%id , config_flags%isice )
700	grid%isice = config_flags%isice
701
702	CALL wrf_get_dom_ti_integer ( fid , 'ISURBAN' , config_flags%isurban , 1 , icnt , ierr )
703	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for ISURBAN returns ',config_flags%isurban
704	CALL wrf_debug ( 300 , wrf_err_message )
705	IF ( ierr .NE. 0 ) THEN
706	IF (mminlu == 'UMD') THEN
707	config_flags%isurban = 13
708	ELSE IF (mminlu == 'MODIFIED_IGBP_MODIS_NOAH') THEN
709	config_flags%isurban = 13
710	ELSE
711	config_flags%isurban = 1
712	ENDIF
713	ENDIF
714	CALL nl_set_isurban ( grid%id , config_flags%isurban )
715	grid%isurban = config_flags%isurban
716
717	CALL wrf_get_dom_ti_integer ( fid , 'ISOILWATER' , config_flags%isoilwater , 1 , icnt , ierr )
718	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for ISOILWATER returns ',config_flags%isoilwater
719	CALL wrf_debug ( 300 , wrf_err_message )
720	IF ( ierr .NE. 0 ) THEN
721	config_flags%isoilwater = 14
722	ENDIF
723	CALL nl_set_isoilwater ( grid%id , config_flags%isoilwater )
724	grid%isoilwater = config_flags%isoilwater
725
726	#ifdef MOVE_NESTS
727	! Added these fields for restarting of moving nests, JM
728	! DANGER and TODO
729	! It is very important that these be set correctly if they are set at all in here.
730	! Garbage values will produce unpredictable results, possibly segfaults, in the nesting
731	! code. Need some integrity checking here or elsewhere in the code to at least check to
732	! make sure that the istart and jstart values make sense with respect to the nest dimensions
733	! and the position in the parent domain.
734	CALL wrf_get_dom_ti_integer ( fid , 'I_PARENT_START' , itmp , 1 , icnt, ierr )
735	IF ( ierr .EQ. 0 .AND. switch .EQ. restart_only ) THEN
736	config_flags%i_parent_start = itmp
737	CALL nl_set_i_parent_start ( grid%id , config_flags%i_parent_start )
738	ENDIF
739	CALL wrf_get_dom_ti_integer ( fid , 'J_PARENT_START' , itmp , 1 , icnt, ierr )
740	IF ( ierr .EQ. 0 .AND. switch .EQ. restart_only ) THEN
741	config_flags%j_parent_start = itmp
742	CALL nl_set_j_parent_start ( grid%id , config_flags%j_parent_start )
743	ENDIF
744	#endif
745
746	#if (EM_CORE == 1)
747
748	!KLUDGE - is there a more elegant way to determine "old si" input
749	IF ( ( switch .EQ. input_only ) .OR. &
750	( ( switch .EQ. auxinput1_only ) .AND. &
751	( config_flags%auxinput1_inname(1:8) .EQ. 'wrf_real' ) ) ) THEN
752
753	! Test to make sure that the input data is the right size.
754
755	IF ( ( ide .NE. ide_compare ) .OR. &
756	( kde .NE. kde_compare ) .OR. &
757	( jde .NE. jde_compare ) ) THEN
758	WRITE(wrf_err_message,*)'input_wrf.F: SIZE MISMATCH: namelist ide,jde,kde=',ide,jde,kde,&
759	'; input data ide,jde,kde=',ide_compare , jde_compare , kde_compare
760	CALL wrf_error_fatal( wrf_err_message )
761	ENDIF
762
763	ELSE IF ( switch .EQ. auxinput1_only ) THEN
764
765	! Test to make sure that the input data is the right size.
766
767	IF ( ( ide .NE. ide_compare ) .OR. &
768	( config_flags%num_metgrid_levels .NE. kde_compare ) .OR. &
769	( jde .NE. jde_compare ) ) THEN
770	WRITE(wrf_err_message,*)'input_wrf.F: SIZE MISMATCH: ',&
771	'namelist ide,jde,num_metgrid_levels=',ide,jde,config_flags%num_metgrid_levels,&
772	'; input data ide,jde,num_metgrid_levels=',ide_compare , jde_compare , kde_compare
773	CALL wrf_error_fatal( wrf_err_message )
774	ENDIF
775	ENDIF
776
777	#endif
778
779	#if (NMM_CORE == 1)
780
781	IF ( ( switch .EQ. auxinput1_only ) .AND. &
782	( config_flags%auxinput1_inname(1:8) .EQ. 'wrf_real' ) ) THEN
783
784	CALL wrf_get_dom_ti_integer ( fid , 'BOTTOM-TOP_GRID_DIMSNSION' , kde_compare , 1 , icnt , ierr3 )
785
786	! Test to make sure that the input data is the right size.
787
788	IF ( ( ide-1 .NE. ide_compare ) .OR. &
789	( kde .NE. kde_compare ) .OR. &
790	( jde-1 .NE. jde_compare ) .AND. ierr3 .EQ. 0 ) THEN
791	WRITE(wrf_err_message,*)'input_wrf.F: SIZE MISMATCH: namelist ide-1,jde-1,kde=',ide-1,jde-1,kde,&
792	'; input data ide,jde,kde=',ide_compare , jde_compare , kde_compare
793	CALL wrf_debug( 100, wrf_err_message )
794	ENDIF
795
796	ELSEIF ( switch .EQ. auxinput1_only ) THEN ! assume just WPS in this branch
797	IF ( ( ide-1 .NE. ide_compare ) .OR. &
798	( config_flags%num_metgrid_levels .NE. kde_compare ) .OR. &
799	( jde-1 .NE. jde_compare ) .AND. ierr3 .EQ. 0 ) THEN
800	WRITE(wrf_err_message,*)'input_wrf.F: SIZE MISMATCH: ',&
801	'namelist ide-1,jde-1,num_metgrid_levels=',ide-1,jde-1,config_flags%num_metgrid_levels,&
802	'; input data ide,jde,num_metgrid_levels=',ide_compare , jde_compare , kde_compare
803	IF (ide-1 .eq. ide_compare .AND. jde-1 .EQ. jde_compare) THEN
804	CALL wrf_message(wrf_err_message)
805	CALL wrf_error_fatal( "appears that the vertical dimension is wrong - quitting" )
806	ELSE
807	CALL wrf_message(wrf_err_message)
808	CALL wrf_error_fatal( "appears that I or J dimensions are wrong - quitting" )
809	ENDIF
810	ENDIF
811	ENDIF
812
813	#endif
814
815	#if (DA_CORE == 1)
816	! Test here to check that config_flags%hypsometric_opt in namelist
817	! is equal to what is in the global attributes of the wrfinput files
818
819	IF ( switch .EQ. input_only ) THEN
820	CALL wrf_get_dom_ti_integer ( fid, 'HYPSOMETRIC_OPT', itmp, 1, icnt, ierr )
821	IF ( ierr .EQ. 0 ) THEN
822	WRITE(wrf_err_message,*)'input_wrf: global attribute HYPSOMETRIC_OPT returns ', itmp
823	CALL wrf_debug ( 300 , wrf_err_message )
824	IF ( config_flags%hypsometric_opt /= itmp ) THEN
825	call wrf_message("----------------- WARNING -------------------")
826	WRITE(wrf_err_message,'("namelist : hypsometric_opt = ",I10)') config_flags%hypsometric_opt
827	call wrf_message(wrf_err_message)
828	WRITE(wrf_err_message,'("input files : HYPSOMETRIC_OPT = ",I10, " (from wrfinput files).")') itmp
829	call wrf_message(wrf_err_message)
830	call wrf_error_fatal("Mismatch between namelist and global attribute HYPSOMETRIC_OPT")
831	END IF
832	END IF
833	END IF
834
835	#endif
836
837	ENDIF check_if_dryrun
838
839	!
840	! This call to wrf_get_next_time will position the dataset over the next time-frame
841	! in the file and return the current_date, which is used as an argument to the
842	! read_field routines in the blocks of code included below. Note that we read the
843	! next time after all the meta data has been read. This is only important for the
844	! WRF internal I/O format because it is order-dependent. Other formats shouldn't care
845	! about this.
846	!
847
848	3003 continue
849
850	CALL wrf_get_next_time(fid, current_date , ierr)
851	WRITE(wrf_err_message,*)fid,' input_wrf: wrf_get_next_time current_date: ',current_date(1:19),' Status = ',ierr
852	CALL wrf_debug ( 300 , TRIM(wrf_err_message ) )
853	IF ( ierr .NE. 0 .AND. ierr .NE. WRF_WARN_NOTSUPPORTED .AND. ierr .NE. WRF_WARN_DRYRUN_READ ) THEN
854	CALL wrf_message ( TRIM(wrf_err_message ) )
855	IF ( switch .EQ. boundary_only ) THEN
856	WRITE(wrf_err_message,*) ' ... May have run out of valid boundary conditions in file ',TRIM(fname)
857	CALL wrf_error_fatal( TRIM(wrf_err_message) )
858	ELSE
859	#if ( NMM_CORE != 1 )
860	WRITE(wrf_err_message,*) '... Could not find matching time in input file ',TRIM(fname)
861	CALL wrf_error_fatal( TRIM(wrf_err_message) )
862	#endif
863	ENDIF
864	ELSE IF ( ierr .NE. WRF_WARN_NOTSUPPORTED .AND. ierr .NE. WRF_WARN_DRYRUN_READ) THEN
865	!
866	! check input time against domain time (which will be start time at beginning, see share/set_timekeeping.F)
867	! JM 20040511
868	!
869	SELECT CASE ( switch )
870	CASE ( input_only, auxinput1_only, auxinput2_only, &
871	auxinput3_only, auxinput4_only, auxinput5_only, &
872	auxinput6_only, auxinput7_only, auxinput8_only, &
873	auxinput9_only, auxinput10_only )
874	#if ( WRF_CHEM == 1 )
875	IF( (config_flags%io_style_emissions .eq. 1) .and. &
876	((switch.eq.auxinput5_only) .or. (switch.eq.auxinput6_only) .or. &
877	(switch.eq.auxinput7_only) .or. (switch.eq.auxinput8_only)) ) then
878	CALL wrf_message( "WARNING Time in input file not being checked WARNING" )
879	ELSE
880	#endif
881	CALL wrf_atotime( current_date(1:19), time )
882	CALL domain_clock_get( grid, current_time=currtime, &
883	current_timestr=currtimestr )
884	#if (DA_CORE != 1)
885	! Don't perform the check for WRFVAR, as we're not passing the right dates
886	! around
887	CALL domain_clockprint(150, grid, &
888	'DEBUG input_wrf(): get CurrTime from clock,')
889	IF ( time .NE. currtime ) THEN
890	WRITE( wrf_err_message , * )'Time in file: ',trim( current_date(1:19) )
891	CALL wrf_message ( trim(wrf_err_message) )
892	WRITE( wrf_err_message , * )'Time on domain: ',trim( currtimestr )
893	CALL wrf_message ( trim(wrf_err_message) )
894	CALL wrf_message( "WARNING Time in input file not equal to time on domain WARNING" )
895	WRITE(wrf_err_message,) "WARNING* Trying next time in file ",TRIM(fname)," ..."
896	CALL wrf_message( TRIM(wrf_err_message) )
897	GOTO 3003
898	ENDIF
899	#endif
900	#if ( WRF_CHEM == 1 )
901	ENDIF
902	#endif
903	CASE DEFAULT
904	END SELECT
905	ENDIF
906
907	! set the lbc time interval fields in the domain data structure
908	! these time values are checked as stopping condition for the while loop in
909	! latbound_in() defined in share/medation_integrate.F, which is used to
910	! iterate forward to the correct interval in the input LBC file
911	!
912	IF ( switch .EQ. boundary_only ) THEN
913	IF ( config_flags%restart ) THEN
914	! get WRF time of current_date position in boundary file
915	CALL wrf_atotime( current_date(1:19), time )
916	! jump straight to the restart time
917	CALL domain_clock_get( grid, current_time=currentTime, &
918	current_timestr=currtimestr )
919	write(wrf_err_message, '(4a)') "WRF restart, LBC starts at ", &
920	& trim(current_date), " and restart starts at ", trim(currtimestr)
921	CALL wrf_debug( 0 , wrf_err_message )
922
923	! While the lateral BC time is less than the restart time, advance forward to the next LBC time.
924
925	DO WHILE (time .lt. currentTime)
926	CALL wrf_get_next_time(fid, current_date , ierr)
927	CALL wrf_atotime(current_date(1:19), time)
928	WRITE(wrf_err_message,*) 'Advancing LBC file: wrf_get_next_time current_date: ',&
929	& current_date(1:19),' Status = ',ierr
930	IF ( ierr .EQ. 0 ) THEN
931	CALL wrf_debug ( 0 , TRIM(wrf_err_message ) )
932	ELSE
933	CALL wrf_error_fatal ( 'Cannot find a valid time to start the LBC during this restart' )
934	END IF
935	END DO
936
937	! Now the LBC time either matches or is beyond the restart time. If it matches, we are at the
938	! right time. If we have gone too far, then back up one time period, and we are good to go.
939
940	IF ( time .eq. currentTime ) THEN
941	CALL wrf_debug ( 0 , 'Found correct time, LBC matches the restart interval.' )
942	ELSE IF ( time .gt. currentTime ) THEN
943	CALL wrf_debug ( 0 , 'Went one LBC interval too far, backing up for restart.' )
944	CALL wrf_get_previous_time(fid, current_date , ierr)
945	IF ( ierr .EQ. 0 ) THEN
946	CALL wrf_atotime(current_date(1:19), time)
947	WRITE(wrf_err_message,*) 'LBC: wrf_get_prev_time current_date: ',&
948	& current_date(1:19),' Status = ',ierr
949	CALL wrf_debug ( 0 , TRIM(wrf_err_message ) )
950	CALL wrf_debug ( 0 , 'LBC is now correctly positioned for requested restart time' )
951	ELSE
952	CALL wrf_error_fatal ( 'Problems backing up in the LBC file to find startig location for restart' )
953	END IF
954	END IF
955
956	CALL wrf_get_dom_td_char ( fid , 'THISBDYTIME' , current_date(1:19), this_datestr , ierr )
957	CALL wrf_atotime( this_datestr(1:19), grid%this_bdy_time )
958	CALL wrf_get_dom_td_char ( fid , 'NEXTBDYTIME' , current_date(1:19), next_datestr , ierr )
959	CALL wrf_atotime( next_datestr(1:19), grid%next_bdy_time )
960
961	ELSE IF ( .NOT. config_flags%restart ) THEN
962	CALL domain_clock_get( grid, current_time=currentTime )
963	CALL wrf_get_dom_td_char ( fid , 'THISBDYTIME' , current_date(1:19), this_datestr , ierr )
964	CALL wrf_atotime( this_datestr(1:19), grid%this_bdy_time )
965	CALL wrf_get_dom_td_char ( fid , 'NEXTBDYTIME' , current_date(1:19), next_datestr , ierr )
966	CALL wrf_atotime( next_datestr(1:19), grid%next_bdy_time )
967	END IF
968	#if (DA_CORE != 1)
969	IF( currentTime .GE. grid%next_bdy_time ) THEN
970	IF ( wrf_dm_on_monitor() ) THEN
971	write(a_message,*) 'THIS TIME ',this_datestr(1:19),'NEXT TIME ',next_datestr(1:19)
972	CALL wrf_message ( a_message )
973	END IF
974	RETURN
975	ENDIF
976	#endif
977	ENDIF
978
979	#if ( ( EM_CORE == 1 ) && ( DA_CORE != 1 ) )
980	! Vertical interpolation space is required if specified by user.
981
982	n_ref_m = config_flags%vert_refine_fact
983	#else
984	! Default value indicating no vertical interpolation required.
985
986	n_ref_m = 0
987	#endif
988
989	IF ( (first_input .LE. switch .AND. switch .LE. last_input) .OR. &
990	(first_history .LE. switch .AND. switch .LE. last_history) .OR. &
991	switch .EQ. restart_only ) THEN
992	newswitch = switch
993	p => grid%head_statevars%next
994	DO WHILE ( ASSOCIATED( p ) )
995	IF ( p%ProcOrient .NE. 'X' .AND. p%ProcOrient .NE. 'Y' ) THEN ! no I/O for xposed variables
996	IF ( p%Ndim .EQ. 0 ) THEN
997	IF ((p%Restart.AND.switch.EQ.restart_only).OR.on_stream( p%streams,newswitch)) THEN
998	IF ( in_use_for_config(grid%id,TRIM(p%VarName)) ) THEN
999	IF (p%Ntl.GT.0.AND.switch.NE.restart_only)dname=dname(1:len(TRIM(dname))-2)
1000	dname = p%DataName
1001	IF (switch.EQ.restart_only.OR.p%Ntl/100.EQ.mod(p%Ntl,100)) THEN
1002	IF ( p%Type .EQ. 'r' ) THEN
1003	CALL wrf_ext_read_field ( &
1004	fid , & ! DataHandle
1005	current_date(1:19) , & ! DateStr
1006	TRIM(dname) , & ! Data Name
1007	p%rfield_0d , & ! Field
1008	WRF_FLOAT , & ! FieldType
1009	grid%communicator , & ! Comm
1010	grid%iocommunicator , & ! Comm
1011	grid%domdesc , & ! Comm
1012	grid%bdy_mask , & ! bdy_mask
1013	'0' , & ! MemoryOrder
1014	'' , & ! Stagger
1015	__FILE__ // ' reading 0d real ' // TRIM(p%VarName) , & ! Debug message
1016	1 , 1 , 1 , 1 , 1 , 1 , &
1017	1 , 1 , 1 , 1 , 1 , 1 , &
1018	1 , 1 , 1 , 1 , 1 , 1 , &
1019	ierr )
1020	ELSE IF ( p%Type .EQ. 'd' ) THEN
1021	CALL wrf_ext_read_field ( &
1022	fid , & ! DataHandle
1023	current_date(1:19) , & ! DateStr
1024	TRIM(dname) , & ! Data Name
1025	p%dfield_0d , & ! Field
1026	WRF_DOUBLE , & ! FieldType
1027	grid%communicator , & ! Comm
1028	grid%iocommunicator , & ! Comm
1029	grid%domdesc , & ! Comm
1030	grid%bdy_mask , & ! bdy_mask
1031	'0' , & ! MemoryOrder
1032	'' , & ! Stagger
1033	__FILE__ // ' reading 0d double ' // TRIM(p%VarName) , & ! Debug message
1034	1 , 1 , 1 , 1 , 1 , 1 , &
1035	1 , 1 , 1 , 1 , 1 , 1 , &
1036	1 , 1 , 1 , 1 , 1 , 1 , &
1037	ierr )
1038	ELSE IF ( p%Type .EQ. 'i' ) THEN
1039	CALL wrf_ext_read_field ( &
1040	fid , & ! DataHandle
1041	current_date(1:19) , & ! DateStr
1042	TRIM(dname) , & ! Data Name
1043	p%ifield_0d , & ! Field
1044	WRF_INTEGER , & ! FieldType
1045	grid%communicator , & ! Comm
1046	grid%iocommunicator , & ! Comm
1047	grid%domdesc , & ! Comm
1048	grid%bdy_mask , & ! bdy_mask
1049	'0' , & ! MemoryOrder
1050	'' , & ! Stagger
1051	__FILE__ // ' reading 0d integer ' // TRIM(p%VarName) , & ! Debug message
1052	1 , 1 , 1 , 1 , 1 , 1 , &
1053	1 , 1 , 1 , 1 , 1 , 1 , &
1054	1 , 1 , 1 , 1 , 1 , 1 , &
1055	ierr )
1056	ELSE IF ( p%Type .EQ. 'l' ) THEN
1057	CALL wrf_ext_read_field ( &
1058	fid , & ! DataHandle
1059	current_date(1:19) , & ! DateStr
1060	TRIM(dname) , & ! Data Name
1061	p%lfield_0d , & ! Field
1062	WRF_LOGICAL , & ! FieldType
1063	grid%communicator , & ! Comm
1064	grid%iocommunicator , & ! Comm
1065	grid%domdesc , & ! Comm
1066	grid%bdy_mask , & ! bdy_mask
1067	'0' , & ! MemoryOrder
1068	'' , & ! Stagger
1069	__FILE__ // ' reading 0d logical ' // TRIM(p%VarName) , & ! Debug message
1070	1 , 1 , 1 , 1 , 1 , 1 , &
1071	1 , 1 , 1 , 1 , 1 , 1 , &
1072	1 , 1 , 1 , 1 , 1 , 1 , &
1073	ierr )
1074	ENDIF
1075	ENDIF
1076	ENDIF
1077	ENDIF
1078	ELSE IF ( p%Ndim .EQ. 1 ) THEN
1079	IF ((p%Restart.AND.switch.EQ.restart_only).OR.on_stream( p%streams,newswitch)) THEN
1080	IF ( in_use_for_config(grid%id,TRIM(p%VarName)) ) THEN
1081	IF (switch.EQ.restart_only.OR.p%Ntl/100.EQ.mod(p%Ntl,100)) THEN
1082	dname = p%DataName
1083	IF (p%Ntl.GT.0.AND.switch.NE.restart_only)dname=dname(1:len(TRIM(dname))-2)
1084	memord = p%MemoryOrder
1085
1086	i_inter = 0
1087	#if ( ( EM_CORE == 1 ) && ( DA_CORE != 1 ) )
1088	! Vertical interpolation space is required if specified by user.
1089
1090	if( TRIM(p%dimname1).EQ.'bottom_top'.OR.TRIM(p%dimname1).EQ.'bottom_top_stag') i_inter = 1
1091	#endif
1092
1093	IF ( p%Type .EQ. 'r' ) THEN
1094	IF( (i_inter.eq.1.and.n_ref_m.ge.2).and.(switch.eq.history_only) ) THEN
1095	em1_c = (p%em1 - 1)/n_ref_m +1
1096	ed1_c = em1_c
1097	ep1_c = em1_c
1098	if (TRIM(p%dimname1).EQ.'bottom_top') then
1099	ed1_c = em1_c-1
1100	ep1_c = em1_c-1
1101	endif
1102	allocate (f_vint_1d(em1_c))
1103
1104	CALL wrf_ext_read_field ( &
1105	fid , & ! DataHandle
1106	current_date(1:19) , & ! DateStr
1107	TRIM(dname) , & ! Data Name
1108	f_vint_1d , & ! Field
1109	WRF_FLOAT , & ! FieldType
1110	grid%communicator , & ! Comm
1111	grid%iocommunicator , & ! Comm
1112	grid%domdesc , & ! Comm
1113	grid%bdy_mask , & ! bdy_mask
1114	TRIM(memord) , & ! MemoryOrder
1115	p%Stagger , & ! Stagger
1116	__FILE__ // ' reading 1d real ' // TRIM(p%VarName) , & ! Debug message
1117	p%sd1 , ed1_c , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1118	p%sm1 , em1_c , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1119	p%sp1 , ep1_c , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1120	ierr )
1121
1122	do k=1,ed1_c
1123	p%rfield_1d(k) = f_vint_1d(k)
1124	enddo
1125	deallocate (f_vint_1d)
1126
1127	ELSE
1128	CALL wrf_ext_read_field ( &
1129	fid , & ! DataHandle
1130	current_date(1:19) , & ! DateStr
1131	TRIM(dname) , & ! Data Name
1132	p%rfield_1d , & ! Field
1133	WRF_FLOAT , & ! FieldType
1134	grid%communicator , & ! Comm
1135	grid%iocommunicator , & ! Comm
1136	grid%domdesc , & ! Comm
1137	grid%bdy_mask , & ! bdy_mask
1138	TRIM(memord) , & ! MemoryOrder
1139	p%Stagger , & ! Stagger
1140	__FILE__ // ' reading 1d real ' // TRIM(p%VarName) , & ! Debug message
1141	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1142	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1143	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1144	ierr )
1145	END IF
1146	ELSE IF ( p%Type .EQ. 'd' ) THEN
1147	CALL wrf_ext_read_field ( &
1148	fid , & ! DataHandle
1149	current_date(1:19) , & ! DateStr
1150	TRIM(dname) , & ! Data Name
1151	p%dfield_1d , & ! Field
1152	WRF_DOUBLE , & ! FieldType
1153	grid%communicator , & ! Comm
1154	grid%iocommunicator , & ! Comm
1155	grid%domdesc , & ! Comm
1156	grid%bdy_mask , & ! bdy_mask
1157	TRIM(memord) , & ! MemoryOrder
1158	TRIM(p%Stagger) , & ! Stagger
1159	__FILE__ // ' reading 1d double ' // TRIM(p%VarName) , & ! Debug message
1160	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1161	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1162	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1163	ierr )
1164	ELSE IF ( p%Type .EQ. 'i' ) THEN
1165	CALL wrf_ext_read_field ( &
1166	fid , & ! DataHandle
1167	current_date(1:19) , & ! DateStr
1168	TRIM(dname) , & ! Data Name
1169	p%ifield_1d , & ! Field
1170	WRF_INTEGER , & ! FieldType
1171	grid%communicator , & ! Comm
1172	grid%iocommunicator , & ! Comm
1173	grid%domdesc , & ! Comm
1174	grid%bdy_mask , & ! bdy_mask
1175	TRIM(memord) , & ! MemoryOrder
1176	TRIM(p%Stagger) , & ! Stagger
1177	__FILE__ // ' reading 1d integer ' // TRIM(p%VarName) , & ! Debug message
1178	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1179	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1180	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1181	ierr )
1182	ELSE IF ( p%Type .EQ. 'l' ) THEN
1183	CALL wrf_ext_read_field ( &
1184	fid , & ! DataHandle
1185	current_date(1:19) , & ! DateStr
1186	TRIM(dname) , & ! Data Name
1187	p%lfield_1d , & ! Field
1188	WRF_LOGICAL , & ! FieldType
1189	grid%communicator , & ! Comm
1190	grid%iocommunicator , & ! Comm
1191	grid%domdesc , & ! Comm
1192	grid%bdy_mask , & ! bdy_mask
1193	TRIM(memord) , & ! MemoryOrder
1194	TRIM(p%Stagger) , & ! Stagger
1195	__FILE__ // ' reading 1d logical ' // TRIM(p%VarName) , & ! Debug message
1196	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1197	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1198	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1199	ierr )
1200	ENDIF
1201	ENDIF
1202	ENDIF
1203	ENDIF
1204	ELSE IF ( p%Ndim .EQ. 2 ) THEN
1205	IF ((p%Restart.AND.switch.EQ.restart_only).OR.on_stream( p%streams,newswitch)) THEN
1206	IF ( in_use_for_config(grid%id,TRIM(p%VarName)) .AND. &
1207	( .NOT. p%subgrid_x .OR. (p%subgrid_x .AND. grid%sr_x .GT. 0) ) .AND. &
1208	( .NOT. p%subgrid_y .OR. (p%subgrid_y .AND. grid%sr_y .GT. 0) ) &
1209	) THEN
1210	IF (switch.EQ.restart_only.OR.p%Ntl/100.EQ.mod(p%Ntl,100)) THEN
1211	dname = p%DataName
1212	IF (p%Ntl.GT.0.AND.switch.NE.restart_only)dname=dname(1:len(TRIM(dname))-2)
1213	memord = p%MemoryOrder
1214	IF ( p%Type .EQ. 'r' ) THEN
1215	CALL wrf_ext_read_field ( &
1216	fid , & ! DataHandle
1217	current_date(1:19) , & ! DateStr
1218	TRIM(dname) , & ! Data Name
1219	p%rfield_2d , & ! Field
1220	WRF_FLOAT , & ! FieldType
1221	grid%communicator , & ! Comm
1222	grid%iocommunicator , & ! Comm
1223	grid%domdesc , & ! Comm
1224	grid%bdy_mask , & ! bdy_mask
1225	TRIM(memord) , & ! MemoryOrder
1226	TRIM(p%Stagger) , & ! Stagger
1227	__FILE__ // ' reading 2d real ' // TRIM(p%VarName) , & ! Debug message
1228	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1229	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1230	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1231	ierr )
1232	ELSE IF ( p%Type .EQ. 'd' ) THEN
1233	CALL wrf_ext_read_field ( &
1234	fid , & ! DataHandle
1235	current_date(1:19) , & ! DateStr
1236	TRIM(dname) , & ! Data Name
1237	p%dfield_2d , & ! Field
1238	WRF_DOUBLE , & ! FieldType
1239	grid%communicator , & ! Comm
1240	grid%iocommunicator , & ! Comm
1241	grid%domdesc , & ! Comm
1242	grid%bdy_mask , & ! bdy_mask
1243	TRIM(memord) , & ! MemoryOrder
1244	TRIM(p%Stagger) , & ! Stagger
1245	__FILE__ // ' reading 2d double ' // TRIM(p%VarName) , & ! Debug message
1246	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1247	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1248	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1249	ierr )
1250	ELSE IF ( p%Type .EQ. 'i' ) THEN
1251	CALL wrf_ext_read_field ( &
1252	fid , & ! DataHandle
1253	current_date(1:19) , & ! DateStr
1254	TRIM(dname) , & ! Data Name
1255	p%ifield_2d , & ! Field
1256	WRF_INTEGER , & ! FieldType
1257	grid%communicator , & ! Comm
1258	grid%iocommunicator , & ! Comm
1259	grid%domdesc , & ! Comm
1260	grid%bdy_mask , & ! bdy_mask
1261	TRIM(memord) , & ! MemoryOrder
1262	TRIM(p%Stagger) , & ! Stagger
1263	__FILE__ // ' reading 2d integer ' // TRIM(p%VarName) , & ! Debug message
1264	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1265	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1266	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1267	ierr )
1268	ELSE IF ( p%Type .EQ. 'l' ) THEN
1269	CALL wrf_ext_read_field ( &
1270	fid , & ! DataHandle
1271	current_date(1:19) , & ! DateStr
1272	TRIM(dname) , & ! Data Name
1273	p%lfield_2d , & ! Field
1274	WRF_LOGICAL , & ! FieldType
1275	grid%communicator , & ! Comm
1276	grid%iocommunicator , & ! Comm
1277	grid%domdesc , & ! Comm
1278	grid%bdy_mask , & ! bdy_mask
1279	TRIM(memord) , & ! MemoryOrder
1280	TRIM(p%Stagger) , & ! Stagger
1281	__FILE__ // ' reading 2d logical ' // TRIM(p%VarName) , & ! Debug message
1282	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1283	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1284	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1285	ierr )
1286	ENDIF
1287	ENDIF
1288	ENDIF
1289	ENDIF
1290	ELSE IF ( p%Ndim .EQ. 3 ) THEN
1291	IF ((p%Restart.AND.switch.EQ.restart_only).OR.on_stream( p%streams,newswitch)) THEN
1292	IF ( in_use_for_config(grid%id,TRIM(p%VarName)) .AND. &
1293	( .NOT. p%subgrid_x .OR. (p%subgrid_x .AND. grid%sr_x .GT. 0) ) .AND. &
1294	( .NOT. p%subgrid_y .OR. (p%subgrid_y .AND. grid%sr_y .GT. 0) ) &
1295	) THEN
1296	IF (switch.EQ.restart_only.OR.p%Ntl/100.EQ.mod(p%Ntl,100)) THEN
1297	dname = p%DataName
1298	IF (p%Ntl.GT.0.AND.switch.NE.restart_only)dname=dname(1:len(TRIM(dname))-2)
1299	memord = p%MemoryOrder
1300
1301	i_inter = 0
1302	#if ( ( EM_CORE == 1 ) && ( DA_CORE != 1 ) )
1303	! Vertical interpolation space is required if specified by user.
1304
1305	if( TRIM(p%dimname2).EQ.'bottom_top'.OR.TRIM(p%dimname2).EQ.'bottom_top_stag') i_inter = 1
1306	#endif
1307
1308	IF ( p%Type .EQ. 'r' ) THEN
1309	IF( (i_inter.eq.1.and.n_ref_m.ge.2).and.(switch.eq.history_only) ) then
1310	em2_c = (p%em2 - 1)/n_ref_m +1
1311	ed2_c = em2_c
1312	ep2_c = em2_c
1313	if (TRIM(p%dimname2).EQ.'bottom_top') then
1314	ed2_c = em2_c-1
1315	ep2_c = em2_c-1
1316	endif
1317	allocate (f_vint_3d(p%sm1:p%em1,em2_c,p%sm3:p%em3))
1318	CALL wrf_ext_read_field ( &
1319	fid , & ! DataHandle
1320	current_date(1:19) , & ! DateStr
1321	TRIM(dname) , & ! Data Name
1322	f_vint_3d , & ! Field
1323	WRF_FLOAT , & ! FieldType
1324	grid%communicator , & ! Comm
1325	grid%iocommunicator , & ! Comm
1326	grid%domdesc , & ! Comm
1327	grid%bdy_mask , & ! bdy_mask
1328	TRIM(memord) , & ! MemoryOrder
1329	TRIM(p%Stagger) , & ! Stagger
1330	__FILE__ // ' reading 3d real ' // TRIM(p%VarName) , & ! Debug message
1331	p%sd1 , p%ed1 , p%sd2 , ed2_c , p%sd3 , p%ed3 , &
1332	p%sm1 , p%em1 , p%sm2 , em2_c , p%sm3 , p%em3 , &
1333	p%sp1 , p%ep1 , p%sp2 , ep2_c , p%sp3 , p%ep3 , &
1334	ierr )
1335
1336	do j = p%sm3,p%em3
1337	do k = 1,ed2_c
1338	do i = p%sm1,p%em1
1339	p%rfield_3d(i,k,j) = f_vint_3d(i,k,j)
1340	enddo
1341	enddo
1342	enddo
1343	deallocate (f_vint_3d)
1344	ELSE
1345	CALL wrf_ext_read_field ( &
1346	fid , & ! DataHandle
1347	current_date(1:19) , & ! DateStr
1348	TRIM(dname) , & ! Data Name
1349	p%rfield_3d , & ! Field
1350	WRF_FLOAT , & ! FieldType
1351	grid%communicator , & ! Comm
1352	grid%iocommunicator , & ! Comm
1353	grid%domdesc , & ! Comm
1354	grid%bdy_mask , & ! bdy_mask
1355	TRIM(memord) , & ! MemoryOrder
1356	TRIM(p%Stagger) , & ! Stagger
1357	__FILE__ // ' reading 3d real ' // TRIM(p%VarName) , & ! Debug message
1358	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1359	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1360	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1361	ierr )
1362	ENDIF
1363	ELSE IF ( p%Type .EQ. 'd' ) THEN
1364	CALL wrf_ext_read_field ( &
1365	fid , & ! DataHandle
1366	current_date(1:19) , & ! DateStr
1367	TRIM(dname) , & ! Data Name
1368	p%dfield_3d , & ! Field
1369	WRF_DOUBLE , & ! FieldType
1370	grid%communicator , & ! Comm
1371	grid%iocommunicator , & ! Comm
1372	grid%domdesc , & ! Comm
1373	grid%bdy_mask , & ! bdy_mask
1374	TRIM(memord) , & ! MemoryOrder
1375	TRIM(p%Stagger) , & ! Stagger
1376	__FILE__ // ' reading 3d double ' // TRIM(p%VarName) , & ! Debug message
1377	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1378	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1379	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1380	ierr )
1381	ELSE IF ( p%Type .EQ. 'i' ) THEN
1382	CALL wrf_ext_read_field ( &
1383	fid , & ! DataHandle
1384	current_date(1:19) , & ! DateStr
1385	TRIM(dname) , & ! Data Name
1386	p%ifield_3d , & ! Field
1387	WRF_INTEGER , & ! FieldType
1388	grid%communicator , & ! Comm
1389	grid%iocommunicator , & ! Comm
1390	grid%domdesc , & ! Comm
1391	grid%bdy_mask , & ! bdy_mask
1392	TRIM(memord) , & ! MemoryOrder
1393	TRIM(p%Stagger) , & ! Stagger
1394	__FILE__ // ' reading 3d integer ' // TRIM(p%VarName) , & ! Debug message
1395	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1396	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1397	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1398	ierr )
1399	! NOTE no io on logical arrays greater than 2d
1400	ENDIF
1401	ENDIF
1402	ENDIF
1403	ENDIF
1404	ELSE IF ( p%Ndim .EQ. 4 .AND. p%scalar_array ) THEN
1405	! Use a different read routine, wrf_ext_read_field_arr, and pass in the
1406	! tracer indeces so that p%rfield_4d can be passsed in without arguments,
1407	! avoiding the possiblity of a copy-in/copy-out problem for some compilers.
1408	! JM 20091208
1409	DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id)
1410	IF ((p%Restart.AND.switch.EQ.restart_only).OR.on_stream( p%streams_table(grid%id,itrace)%stream,newswitch)) THEN
1411	dname = p%dname_table( grid%id, itrace )
1412	IF (p%Ntl.GT.0.AND.switch.NE.restart_only)dname=dname(1:len(TRIM(dname))-2)
1413	memord = p%MemoryOrder
1414
1415	i_inter = 0
1416	#if ( ( EM_CORE == 1 ) && ( DA_CORE != 1 ) )
1417	! Vertical interpolation space is required if specified by user.
1418
1419	if( TRIM(p%dimname2).EQ.'bottom_top'.OR.TRIM(p%dimname2).EQ.'bottom_top_stag') i_inter = 1
1420	#endif
1421
1422	IF ( p%Type .EQ. 'r' ) THEN
1423	IF( (i_inter.eq.1.and.n_ref_m.ge.2).and.(switch.eq.history_only) ) then
1424	em2_c = (p%em2 - 1)/n_ref_m +1
1425	ed2_c = em2_c
1426	ep2_c = em2_c
1427	if (TRIM(p%dimname2).EQ.'bottom_top') then
1428	ed2_c = em2_c-1
1429	ep2_c = em2_c-1
1430	endif
1431	allocate (f_vint_4d(p%sm1:p%em1,em2_c,p%sm3:p%em3,p%num_table(grid%id)))
1432
1433	CALL wrf_ext_read_field_arr ( &
1434	fid , & ! DataHandle
1435	current_date(1:19) , & ! DateStr
1436	TRIM(dname) , & ! Data Name
1437	f_vint_4d , & ! Field
1438	itrace, 1, 1, 1 , & ! see comment above
1439	1, 1, 1 , & ! see comment above
1440	RWORDSIZE , &
1441	WRF_FLOAT , & ! FieldType
1442	grid%communicator , & ! Comm
1443	grid%iocommunicator , & ! Comm
1444	grid%domdesc , & ! Comm
1445	grid%bdy_mask , & ! bdy_mask
1446	TRIM(memord) , & ! MemoryOrder
1447	TRIM(p%Stagger) , & ! Stagger
1448	__FILE__ // ' reading 4d real ' // TRIM(p%dname_table(grid%id,itrace)) , & ! Debug message
1449	p%sd1 , p%ed1 , p%sd2 , ed2_c , p%sd3 , p%ed3 , &
1450	p%sm1 , p%em1 , p%sm2 , em2_c , p%sm3 , p%em3 , &
1451	p%sp1 , p%ep1 , p%sp2 , ep2_c , p%sp3 , p%ep3 , &
1452	ierr )
1453	do j = p%sm3,p%em3
1454	do k = 1,ed2_c
1455	do i = p%sm1,p%em1
1456	p%rfield_4d(i,k,j,itrace) = f_vint_4d(i,k,j,itrace)
1457	enddo
1458	enddo
1459	enddo
1460	deallocate (f_vint_4d)
1461	ELSE
1462	CALL wrf_ext_read_field_arr ( &
1463	fid , & ! DataHandle
1464	current_date(1:19) , & ! DateStr
1465	TRIM(dname) , & ! Data Name
1466	p%rfield_4d , & ! Field
1467	itrace, 1, 1, 1 , & ! see comment above
1468	1, 1, 1 , & ! see comment above
1469	RWORDSIZE , &
1470	WRF_FLOAT , & ! FieldType
1471	grid%communicator , & ! Comm
1472	grid%iocommunicator , & ! Comm
1473	grid%domdesc , & ! Comm
1474	grid%bdy_mask , & ! bdy_mask
1475	TRIM(memord) , & ! MemoryOrder
1476	TRIM(p%Stagger) , & ! Stagger
1477	__FILE__ // ' reading 4d real ' // TRIM(p%dname_table(grid%id,itrace)) , & ! Debug message
1478	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1479	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1480	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1481	ierr )
1482	ENDIF
1483	ELSE IF ( p%Type .EQ. 'd' ) THEN
1484	CALL wrf_ext_read_field_arr ( &
1485	fid , & ! DataHandle
1486	current_date(1:19) , & ! DateStr
1487	TRIM(dname) , & ! Data Name
1488	p%dfield_4d , & ! Field
1489	itrace, 1, 1, 1 , & ! see comment above
1490	1, 1, 1 , & ! see comment above
1491	DWORDSIZE , &
1492	WRF_DOUBLE , & ! FieldType
1493	grid%communicator , & ! Comm
1494	grid%iocommunicator , & ! Comm
1495	grid%domdesc , & ! Comm
1496	grid%bdy_mask , & ! bdy_mask
1497	TRIM(memord) , & ! MemoryOrder
1498	TRIM(p%Stagger) , & ! Stagger
1499	__FILE__ // ' reading 4d double ' // TRIM(p%dname_table(grid%id,itrace)) , & ! Debug message
1500	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1501	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1502	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1503	ierr )
1504	ELSE IF ( p%Type .EQ. 'i' ) THEN
1505	CALL wrf_ext_read_field_arr ( &
1506	fid , & ! DataHandle
1507	current_date(1:19) , & ! DateStr
1508	TRIM(dname) , & ! Data Name
1509	p%ifield_4d , & ! Field
1510	itrace, 1, 1, 1 , & ! see comment above
1511	1, 1, 1 , & ! see comment above
1512	IWORDSIZE , &
1513	WRF_INTEGER , & ! FieldType
1514	grid%communicator , & ! Comm
1515	grid%iocommunicator , & ! Comm
1516	grid%domdesc , & ! Comm
1517	grid%bdy_mask , & ! bdy_mask
1518	TRIM(memord) , & ! MemoryOrder
1519	TRIM(p%Stagger) , & ! Stagger
1520	__FILE__ // ' reading 4d integer ' // TRIM(p%dname_table(grid%id,itrace)) , & ! Debug message
1521	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1522	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1523	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1524	ierr )
1525	ENDIF
1526	ENDIF
1527	ENDDO ! loop over tracers
1528	ENDIF
1529	ENDIF
1530	p => p%next
1531	ENDDO
1532	ELSE
1533	IF ( switch .EQ. boundary_only ) THEN
1534	CALL wrf_bdyin( fid , grid , config_flags , switch , ierr )
1535	ENDIF
1536	ENDIF
1537
1538	#if (DA_CORE != 1)
1539	CALL wrf_tsin( grid , ierr )
1540	#if WRFMEAS
1541	! L. Fita, LMD. May 2014
1542	CALL wrf_lidarin( grid , ierr )
1543	#endif
1544
1545	#if (EM_CORE == 1)
1546	if (config_flags%track_loc_in > 0 ) then
1547	call track_input( grid , ierr )
1548	end if
1549	#endif
1550	#endif
1551
1552	WRITE(wrf_err_message,*)'input_wrf: end, fid = ',fid
1553	CALL wrf_debug( 300 , wrf_err_message )
1554
1555	RETURN
1556	END SUBROUTINE input_wrf

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

Download in other formats:

Original Format