Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

input_wrf.F @ 2661

Last change on this file since 2661 was 1, checked in by lfita, 10 years ago

-- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

File size: 68.3 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	!<DESCRIPTION>
93	!
94	! Core wrf input routine for all input data streams. Part of mediation layer.
95	!
96	! Note that WRF IOAPI routines wrf_get_dom_ti_*() do not return values during
97	! training reads (dryrun).
98	!
99	!</DESCRIPTION>
100
101	WRITE(wrf_err_message,*)'input_wrf: begin, fid = ',fid
102	CALL wrf_debug( 300 , wrf_err_message )
103
104	CALL modify_io_masks ( grid%id ) ! this adjusts the I/O masks according to the users run-time specs, if any
105
106	ierr = 0
107
108	CALL get_ijk_from_grid ( grid , &
109	ids, ide, jds, jde, kds, kde, &
110	ims, ime, jms, jme, kms, kme, &
111	ips, ipe, jps, jpe, kps, kpe )
112
113	! If this was not a training read (dry run) check for erroneous values.
114	CALL wrf_inquire_filename ( fid , fname , filestate , ierr )
115	IF ( ierr /= 0 ) THEN
116	WRITE(wrf_err_message,*)'module_io_wrf: input_wrf: wrf_inquire_filename Status = ',ierr
117	CALL wrf_error_fatal( wrf_err_message )
118	ENDIF
119
120	WRITE(wrf_err_message,*)'input_wrf: fid,filestate = ',fid,filestate
121	CALL wrf_debug( 300 , wrf_err_message )
122
123	dryrun = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED )
124
125	WRITE(wrf_err_message,*)'input_wrf: dryrun = ',dryrun
126	CALL wrf_debug( 300 , wrf_err_message )
127
128	check_if_dryrun : IF ( .NOT. dryrun ) THEN
129
130	! simulation start time is a Singleton maintained by head_grid
131	IF ( ( switch .EQ. input_only ) .OR. &
132	( switch .EQ. restart_only ) ) THEN
133
134	IF ( switch .EQ. restart_only .AND. .NOT. config_flags%override_restart_timers ) THEN
135	! recover the restart alarms from input if avialable
136
137	CALL wrf_get_dom_ti_integer( fid , 'MAX_WRF_ALARMS', max_wrf_alarms_compare, 1, icnt, ierr )
138	IF ( max_wrf_alarms_compare .NE. MAX_WRF_ALARMS ) THEN
139	WRITE(wrf_err_message,*)'MAX_WRF_ALARMS different in restart file (',max_wrf_alarms_compare,&
140	') from in code (',MAX_WRF_ALARMS,'). Disregarding info in restart file.'
141	ELSE
142	curtime = domain_get_current_time( grid )
143	DO i = 1, MAX_WRF_ALARMS
144	IF ( grid%alarms_created(i) .AND. .NOT. i .EQ. boundary_only ) THEN
145	write(alarmname,'("WRF_ALARM_ISRINGING_",i2.2)')i
146	CALL wrf_get_dom_ti_integer( fid, TRIM(alarmname), iring, 1, icnt, ierr )
147
148	write(alarmname,'("WRF_ALARM_SECS_TIL_NEXT_RING_",i2.2)')i
149	CALL wrf_get_dom_ti_integer( fid, TRIM(alarmname), seconds, 1, icnt, ierr )
150	IF ( ierr .EQ. 0 &
151	.AND. seconds .GE. 0 ) THEN ! disallow negative intervals; can happen with wrfbdy datasets
152	! which keep time differently
153
154	! Get and set interval so that we are sure to have both the
155	! interval and first ring time set correctly
156	CALL WRFU_AlarmGet( grid%alarms(i), ringinterval=interval2 )
157	CALL WRFU_TimeIntervalSet(interval,S=seconds)
158	ringTime = curtime + interval
159	CALL WRFU_AlarmSet( grid%alarms(i), RingInterval=interval2, RingTime=ringTime )
160
161	ENDIF
162
163	IF ( iring .EQ. 1 ) THEN
164	CALL WRFU_AlarmRingerOn( grid%alarms( i ) )
165	ELSE
166	CALL WRFU_AlarmRingerOff( grid%alarms( i ) )
167	ENDIF
168	ENDIF
169	ENDDO
170	ENDIF
171
172	ENDIF
173
174	CALL wrf_get_dom_ti_char ( fid , 'SIMULATION_START_DATE' , simulation_start_date , ierr )
175	CALL nl_get_reset_simulation_start ( 1, reset_simulation_start )
176	IF ( ( ierr .EQ. 0 ) .AND. ( .NOT. reset_simulation_start ) ) THEN
177	! Overwrite simulation start date with metadata.
178	#ifdef PLANET
179	READ ( simulation_start_date , fmt = '(I4,1x,I5,1x,I2,1x,I2,1x,I2)' ) &
180	simulation_start_year, &
181	simulation_start_day, simulation_start_hour, &
182	simulation_start_minute, simulation_start_second
183	simulation_start_month = 0
184	#else
185	READ ( simulation_start_date , fmt = '(I4,1x,I2,1x,I2,1x,I2,1x,I2,1x,I2)' ) &
186	simulation_start_year, simulation_start_month, &
187	simulation_start_day, simulation_start_hour, &
188	simulation_start_minute, simulation_start_second
189	#endif
190	CALL nl_set_simulation_start_year ( 1 , simulation_start_year )
191	CALL nl_set_simulation_start_month ( 1 , simulation_start_month )
192	CALL nl_set_simulation_start_day ( 1 , simulation_start_day )
193	CALL nl_set_simulation_start_hour ( 1 , simulation_start_hour )
194	CALL nl_set_simulation_start_minute ( 1 , simulation_start_minute )
195	CALL nl_set_simulation_start_second ( 1 , simulation_start_second )
196	IF ( switch .EQ. input_only ) THEN
197	WRITE(wrf_err_message,*)fid,' input_wrf, input_only: SIMULATION_START_DATE = ', &
198	simulation_start_date(1:19)
199	CALL wrf_debug ( 300 , TRIM(wrf_err_message ) )
200	ELSE IF ( switch .EQ. restart_only ) THEN
201	WRITE(wrf_err_message,*)fid,' input_wrf, restart_only: SIMULATION_START_DATE = ', &
202	simulation_start_date(1:19)
203	CALL wrf_debug ( 300 , TRIM(wrf_err_message ) )
204	ENDIF
205	ELSE
206	CALL nl_get_start_year ( 1 , simulation_start_year )
207	CALL nl_get_start_month ( 1 , simulation_start_month )
208	CALL nl_get_start_day ( 1 , simulation_start_day )
209	CALL nl_get_start_hour ( 1 , simulation_start_hour )
210	CALL nl_get_start_minute ( 1 , simulation_start_minute )
211	CALL nl_get_start_second ( 1 , simulation_start_second )
212	CALL nl_set_simulation_start_year ( 1 , simulation_start_year )
213	CALL nl_set_simulation_start_month ( 1 , simulation_start_month )
214	CALL nl_set_simulation_start_day ( 1 , simulation_start_day )
215	CALL nl_set_simulation_start_hour ( 1 , simulation_start_hour )
216	CALL nl_set_simulation_start_minute ( 1 , simulation_start_minute )
217	CALL nl_set_simulation_start_second ( 1 , simulation_start_second )
218	IF ( reset_simulation_start ) THEN
219	CALL wrf_message('input_wrf: forcing SIMULATION_START_DATE = head_grid start time')
220	CALL wrf_message(' due to namelist variable reset_simulation_start')
221	ELSE
222	CALL wrf_message('input_wrf: SIMULATION_START_DATE not available in input')
223	CALL wrf_message('will use head_grid start time from namelist')
224	ENDIF
225	ENDIF
226	! Initialize derived time quantity in grid%xtime.
227	! Note that this call is also made in setup_timekeeping().
228	! Ugh, what a hack. Simplify all this later...
229	CALL domain_clock_get( grid, minutesSinceSimulationStart=grid%xtime )
230	! Note that it is NOT necessary to reset grid%julian here.
231	WRITE(wrf_err_message,*) 'input_wrf: set xtime to ',grid%xtime
232	CALL wrf_debug ( 100, TRIM(wrf_err_message) )
233	ELSE IF ( switch .EQ. auxinput1_only ) then
234	CALL wrf_get_dom_ti_char ( fid , 'SIMULATION_START_DATE' , first_date_input , ierr )
235	WRITE(wrf_err_message,*)'metgrid input_wrf.F first_date_input = ',first_date_input
236	CALL wrf_message(wrf_err_message)
237	CALL nl_get_start_year ( 1 , first_date_start_year )
238	CALL nl_get_start_month ( 1 , first_date_start_month )
239	CALL nl_get_start_day ( 1 , first_date_start_day )
240	CALL nl_get_start_hour ( 1 , first_date_start_hour )
241	CALL nl_get_start_minute ( 1 , first_date_start_minute )
242	CALL nl_get_start_second ( 1 , first_date_start_second )
243	WRITE ( first_date_nml, fmt = '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) &
244	first_date_start_year, first_date_start_month, &
245	first_date_start_day, first_date_start_hour, &
246	first_date_start_minute, first_date_start_second
247	WRITE (wrf_err_message,*) 'metgrid input_wrf.F first_date_nml = ',first_date_nml
248	CALL wrf_message( TRIM(wrf_err_message ) )
249	ENDIF
250
251	! Test to make sure that the input data is the right size. Do this for input from real/ideal into
252	! WRF, and from the standard initialization into real.
253
254	IF ( ( switch .EQ. input_only ) .OR. &
255	( switch .EQ. auxinput1_only ) ) THEN
256	ierr = 0
257	CALL wrf_get_dom_ti_integer ( fid , 'WEST-EAST_GRID_DIMENSION' , ide_compare , 1 , icnt , ierr3 )
258	ierr = max( ierr, ierr3 )
259	CALL wrf_get_dom_ti_integer ( fid , 'SOUTH-NORTH_GRID_DIMENSION' , jde_compare , 1 , icnt , ierr3 )
260	ierr = max( ierr, ierr3 )
261	CALL wrf_get_dom_ti_integer ( fid , 'BOTTOM-TOP_GRID_DIMENSION' , kde_compare , 1 , icnt , ierr3 )
262	ierr = max( ierr, ierr3 )
263	IF ( ierr3 .NE. 0 ) CALL wrf_error_fatal( 'wrf_get_dom_ti_integer getting dimension information from dataset' )
264
265	#if (EM_CORE == 1)
266	! Test to make sure that the grid distances are the right size.
267
268	CALL wrf_get_dom_ti_real ( fid , 'DX' , dx_compare , 1 , icnt , ierr )
269	CALL wrf_get_dom_ti_real ( fid , 'DY' , dy_compare , 1 , icnt , ierr )
270	IF ( ( ABS ( dx_compare - config_flags%dx ) .GT. 1.E-5 * dx_compare ) .OR. &
271	( ABS ( dy_compare - config_flags%dy ) .GT. 1.E-5 * dy_compare ) ) THEN
272	IF ( ( config_flags%polar ) .AND. ( config_flags%grid_id .EQ. 1 ) ) THEN
273	WRITE(wrf_err_message,*)'input_wrf: DX and DY from input file expected to be wrong'
274	CALL wrf_debug ( 1 , wrf_err_message )
275	ELSE
276	WRITE(wrf_err_message,*)'dx and dy from file ',dx_compare,dy_compare
277	CALL wrf_message(wrf_err_message)
278	WRITE(wrf_err_message,*)'dx and dy from namelist ',config_flags%dx,config_flags%dy
279	CALL wrf_message(wrf_err_message)
280	CALL wrf_error_fatal( 'DX and DY do not match comparing namelist to the input file' )
281	END IF
282	END IF
283	#endif
284	END IF
285
286	! do the check later (see check_if_dryrun below)
287
288	! We do not want the CEN_LAT LON values from the boundary file. For 1-way nests
289	! with ndown, this ends up being the data from the previous coarse domain.
290
291	IF ( switch .NE. boundary_only ) THEN
292	CALL wrf_get_dom_ti_real ( fid , 'CEN_LAT' , config_flags%cen_lat , 1 , icnt , ierr )
293	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for CEN_LAT returns ',config_flags%cen_lat
294	CALL wrf_debug ( 300 , wrf_err_message )
295	CALL nl_set_cen_lat ( grid%id , config_flags%cen_lat )
296
297	CALL wrf_get_dom_ti_real ( fid , 'CEN_LON' , config_flags%cen_lon , 1 , icnt , ierr )
298	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for CEN_LON returns ',config_flags%cen_lon
299	CALL wrf_debug ( 300 , wrf_err_message )
300	CALL nl_set_cen_lon ( grid%id , config_flags%cen_lon )
301	ELSE
302	CALL wrf_get_dom_ti_real ( fid , 'CEN_LAT' , dum , 1 , icnt , ierr )
303	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for CEN_LAT returns ',dum
304	CALL wrf_debug ( 300 , wrf_err_message )
305
306	CALL wrf_get_dom_ti_real ( fid , 'CEN_LON' , dum , 1 , icnt , ierr )
307	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for CEN_LON returns ',dum
308	CALL wrf_debug ( 300 , wrf_err_message )
309	END IF
310
311	CALL wrf_get_dom_ti_real ( fid , 'TRUELAT1' , config_flags%truelat1 , 1 , icnt , ierr )
312	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for TRUELAT1 returns ',config_flags%truelat1
313	CALL wrf_debug ( 300 , wrf_err_message )
314	CALL nl_set_truelat1 ( grid%id , config_flags%truelat1 )
315
316	CALL wrf_get_dom_ti_real ( fid , 'TRUELAT2' , config_flags%truelat2 , 1 , icnt , ierr )
317	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for TRUELAT2 returns ',config_flags%truelat2
318	CALL wrf_debug ( 300 , wrf_err_message )
319	CALL nl_set_truelat2 ( grid%id , config_flags%truelat2 )
320
321	CALL wrf_get_dom_ti_real ( fid , 'MOAD_CEN_LAT' , config_flags%moad_cen_lat , 1 , icnt , ierr )
322	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for MOAD_CEN_LAT returns ',config_flags%moad_cen_lat
323	CALL wrf_debug ( 300 , wrf_err_message )
324	CALL nl_set_moad_cen_lat ( grid%id , config_flags%moad_cen_lat )
325
326	CALL wrf_get_dom_ti_real ( fid , 'STAND_LON' , config_flags%stand_lon , 1 , icnt , ierr )
327	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for STAND_LON returns ',config_flags%stand_lon
328	CALL wrf_debug ( 300 , wrf_err_message )
329	CALL nl_set_stand_lon ( grid%id , config_flags%stand_lon )
330
331	#if ( NMM_CORE != 1 )
332
333	CALL wrf_get_dom_ti_real ( fid , 'POLE_LAT' , config_flags%pole_lat , 1 , icnt , ierr )
334	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for POLE_LAT returns ',config_flags%pole_lat
335	CALL wrf_debug ( 300 , wrf_err_message )
336	CALL nl_set_pole_lat ( grid%id , config_flags%pole_lat )
337
338	CALL wrf_get_dom_ti_real ( fid , 'POLE_LON' , config_flags%pole_lon , 1 , icnt , ierr )
339	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for POLE_LON returns ',config_flags%pole_lon
340	CALL wrf_debug ( 300 , wrf_err_message )
341	CALL nl_set_pole_lon ( grid%id , config_flags%pole_lon )
342
343	! program_name is defined in module_domain and set in the main program for whatever application
344	! is using subroutine input_wrf (that is, the subroutine you are looking at here). Data files
345	! written by SI have P_TOP as a metadata item; the real program and wrf model have it as a
346	! state variable. This test is to supress non-fatal but confusing messages from the model complaining
347	! that P_TOP cannot be read from the metadata for this dataset. JM 20040905
348	!
349	! Note, P_TOP is not defined in the NMM core.
350
351	IF ( program_name(1:7) .EQ. "REAL_EM" ) THEN
352	CALL wrf_get_dom_ti_real ( fid , 'P_TOP' , grid%p_top , 1 , icnt , ierr )
353	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for P_TOP returns ',grid%p_top
354	CALL wrf_debug ( 300 , wrf_err_message )
355	ENDIF
356	#endif
357
358	IF ( switch .NE. boundary_only ) THEN
359	CALL wrf_get_dom_ti_real ( fid , 'GMT' , config_flags%gmt , 1 , icnt , ierr )
360	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for GMT returns ',config_flags%gmt
361	CALL wrf_debug ( 300 , wrf_err_message )
362	CALL nl_set_gmt ( grid%id , config_flags%gmt )
363
364	CALL wrf_get_dom_ti_integer ( fid , 'JULYR' , config_flags%julyr , 1 , icnt , ierr )
365	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for JULYR returns ',config_flags%julyr
366	CALL wrf_debug ( 300 , wrf_err_message )
367	CALL nl_set_julyr ( grid%id , config_flags%julyr )
368
369	CALL wrf_get_dom_ti_integer ( fid , 'JULDAY' , config_flags%julday , 1 , icnt , ierr )
370	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for JULDAY returns ',config_flags%julday
371	CALL wrf_debug ( 300 , wrf_err_message )
372	CALL nl_set_julday ( grid%id , config_flags%julday )
373	ENDIF
374
375	CALL wrf_get_dom_ti_integer ( fid , 'MAP_PROJ' , config_flags%map_proj , 1 , icnt , ierr )
376	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for MAP_PROJ returns ',config_flags%map_proj
377	CALL wrf_debug ( 300 , wrf_err_message )
378	CALL nl_set_map_proj ( grid%id , config_flags%map_proj )
379	grid%map_proj = config_flags%map_proj
380
381	CALL wrf_get_dom_ti_char ( fid , 'MMINLU', mminlu , ierr )
382	IF ( ierr .NE. 0 ) THEN
383	WRITE(wrf_err_message,*)'MMINLU error on input'
384	CALL wrf_debug ( 0 , wrf_err_message )
385	mminlu = " "
386	ELSE IF ( ( ( mminlu(1:1) .GE. "A" ) .AND. ( mminlu(1:1) .LE. "Z" ) ) .OR. &
387	( ( mminlu(1:1) .GE. "a" ) .AND. ( mminlu(1:1) .LE. "z" ) ) .OR. &
388	( ( mminlu(1:1) .GE. "0" ) .AND. ( mminlu(1:1) .LE. "9" ) ) ) THEN
389	! no-op, the mminlu field is probably OK
390	ELSE IF ( mminlu(1:1) .EQ. " " ) THEN
391	mminlu = " "
392	ELSE
393	mminlu = " "
394	END IF
395	call wrf_debug( 1 , "mminlu = '" // TRIM(mminlu) // "'")
396	if (index(mminlu, char(0)) > 0) mminlu(index(mminlu, char(0)):) = " "
397	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_char for MMINLU returns ' // TRIM(mminlu)
398	CALL wrf_debug ( 300 , wrf_err_message )
399	CALL nl_set_mminlu ( grid%id, mminlu )
400
401	! Test to make sure that the number of land categories is set correctly
402	! The default is set to 24 somewhere, from the number of categories
403	! in the traditional USGS dataset
404
405	call wrf_get_dom_ti_integer(fid, "NUM_LAND_CAT", num_land_cat_compare, 1, icnt, ierr)
406	if ( (ierr .NE. 0) .OR. ( num_land_cat_compare .LT. 1 ) .OR. ( num_land_cat_compare .GT. 1000 ) ) then
407	call wrf_debug( 1 , "Must be old WPS data, assuming 24 levels for NUM_LAND_CAT")
408	num_land_cat_compare = 24
409	! call wrf_error_fatal("Error trying to find global attribute 'NUM_LAND_CAT'")
410	endif
411	if ( config_flags%num_land_cat /= num_land_cat_compare ) then
412	call wrf_message("----------------- ERROR -------------------")
413	WRITE(wrf_err_message,'("namelist : NUM_LAND_CAT = ",I10)') config_flags%num_land_cat
414	call wrf_message(wrf_err_message)
415	WRITE(wrf_err_message,'("input files : NUM_LAND_CAT = ",I10, " (from geogrid selections).")') num_land_cat_compare
416	call wrf_message(wrf_err_message)
417	call wrf_error_fatal("Mismatch between namelist and wrf input files for dimension NUM_LAND_CAT")
418	endif
419
420	! Test here to check that config_flags%num_metgrid_soil_levels in namelist
421	! is equal to what is in the global attributes of the met_em files. Note that
422	! if this is not the first time period, we don't really care about soil data.
423
424	IF ( ( switch .EQ. auxinput1_only ) .AND. &
425	( first_date_nml .EQ. first_date_input ) ) THEN
426	CALL wrf_get_dom_ti_integer ( fid, 'NUM_METGRID_SOIL_LEVELS', itmp, 1, icnt, ierr )
427
428	#if (EM_CORE == 1)
429	IF ( itmp .EQ. 1 ) THEN
430	call wrf_error_fatal("NUM_METGRID_SOIL_LEVELS must be greater than 1")
431	END IF
432	#endif
433
434	IF ( ierr .EQ. 0 ) THEN
435	WRITE(wrf_err_message,*)'input_wrf: global attribute NUM_METGRID_SOIL_LEVELS returns ', itmp
436	CALL wrf_debug ( 300 , wrf_err_message )
437	IF ( config_flags%num_metgrid_soil_levels /= itmp ) THEN
438	call wrf_message("----------------- ERROR -------------------")
439	WRITE(wrf_err_message,'("namelist : num_metgrid_soil_levels = ",I10)') config_flags%num_metgrid_soil_levels
440	call wrf_message(wrf_err_message)
441	#if (EM_CORE == 1)
442	WRITE(wrf_err_message,'("input files : NUM_METGRID_SOIL_LEVELS = ",I10, " (from met_em files).")') itmp
443	#else
444	WRITE(wrf_err_message,'("input files : NUM_METGRID_SOIL_LEVELS = ",I10, " (from met_nmm files).")') itmp
445	#endif
446	call wrf_message(wrf_err_message)
447	call wrf_error_fatal("Mismatch between namelist and global attribute NUM_METGRID_SOIL_LEVELS")
448	END IF
449	END IF
450	END IF
451
452	#if 0
453	#ifdef WRF_CHEM
454	! Dust erosion static data.
455
456	CALL wrf_get_dom_ti_integer ( fid, 'EROSION_DIM', itmp, 1, icnt, ierr )
457
458	IF ( ierr .EQ. 0 ) THEN
459	WRITE(wrf_err_message,*)'input_wrf: global attribute EROSION_DIM returns ', itmp
460	CALL wrf_debug ( 300 , wrf_err_message )
461	IF ( config_flags%erosion_dim /= itmp ) THEN
462	call wrf_message("----------------- ERROR -------------------")
463	WRITE(wrf_err_message,'("namelist : erosion_dim = ",I10)') config_flags%erosion_dim
464	call wrf_message(wrf_err_message)
465	WRITE(wrf_err_message,'("input files : EROSION_DIM = ",I10, " (from met_em files).")') itmp
466	call wrf_message(wrf_err_message)
467	call wrf_error_fatal("Mismatch between namelist and global attribute EROSION_DIM")
468	END IF
469	END IF
470	#endif
471	#endif
472
473	! Test here to check that config_flags%sf_surface_physics in namelist
474	! is equal to what is in the global attributes of the wrfinput files
475
476	IF ( switch .EQ. input_only ) THEN
477	CALL wrf_get_dom_ti_integer ( fid, 'SF_SURFACE_PHYSICS', itmp, 1, icnt, ierr )
478	IF ( ierr .EQ. 0 ) THEN
479	WRITE(wrf_err_message,*)'input_wrf: global attribute SF_SURFACE_PHYSICS returns ', itmp
480	CALL wrf_debug ( 300 , wrf_err_message )
481	IF ( config_flags%sf_surface_physics /= itmp ) THEN
482	call wrf_message("----------------- ERROR -------------------")
483	WRITE(wrf_err_message,'("namelist : sf_surface_physics = ",I10)') config_flags%sf_surface_physics
484	call wrf_message(wrf_err_message)
485	WRITE(wrf_err_message,'("input files : SF_SURFACE_PHYSICS = ",I10, " (from wrfinput files).")') itmp
486	call wrf_message(wrf_err_message)
487	call wrf_error_fatal("Mismatch between namelist and global attribute SF_SURFACE_PHYSICS")
488	END IF
489	END IF
490	END IF
491
492
493	CALL wrf_get_dom_ti_integer ( fid , 'ISWATER' , config_flags%iswater , 1 , icnt , ierr )
494	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for ISWATER returns ',config_flags%iswater
495	CALL wrf_debug ( 300 , wrf_err_message )
496	IF ( ierr .NE. 0 ) THEN
497	IF (mminlu == 'UMD') THEN
498	config_flags%iswater = 14
499	ELSE
500	config_flags%iswater = 16
501	ENDIF
502	ENDIF
503	CALL nl_set_iswater ( grid%id , config_flags%iswater )
504	grid%iswater = config_flags%iswater
505
506	CALL wrf_get_dom_ti_integer ( fid , 'ISLAKE' , config_flags%islake , 1 , icnt , ierr )
507	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for ISLAKE returns ',config_flags%islake
508	CALL wrf_debug ( 300 , wrf_err_message )
509	IF ( ierr .NE. 0 ) THEN
510	config_flags%islake = -1
511	ENDIF
512	CALL nl_set_islake ( grid%id , config_flags%islake )
513	grid%islake = config_flags%islake
514
515	CALL wrf_get_dom_ti_integer ( fid , 'ISICE' , config_flags%isice , 1 , icnt , ierr )
516	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for ISICE returns ',config_flags%isice
517	CALL wrf_debug ( 300 , wrf_err_message )
518	IF ( ierr .NE. 0 ) THEN
519	IF (mminlu == 'UMD') THEN
520	config_flags%isice = 14
521	ELSE
522	config_flags%isice = 24
523	ENDIF
524	ENDIF
525	CALL nl_set_isice ( grid%id , config_flags%isice )
526	grid%isice = config_flags%isice
527
528	CALL wrf_get_dom_ti_integer ( fid , 'ISURBAN' , config_flags%isurban , 1 , icnt , ierr )
529	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for ISURBAN returns ',config_flags%isurban
530	CALL wrf_debug ( 300 , wrf_err_message )
531	IF ( ierr .NE. 0 ) THEN
532	IF (mminlu == 'UMD') THEN
533	config_flags%isurban = 13
534	ELSE
535	config_flags%isurban = 1
536	ENDIF
537	ENDIF
538	CALL nl_set_isurban ( grid%id , config_flags%isurban )
539	grid%isurban = config_flags%isurban
540
541	CALL wrf_get_dom_ti_integer ( fid , 'ISOILWATER' , config_flags%isoilwater , 1 , icnt , ierr )
542	WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for ISOILWATER returns ',config_flags%isoilwater
543	CALL wrf_debug ( 300 , wrf_err_message )
544	IF ( ierr .NE. 0 ) THEN
545	config_flags%isoilwater = 14
546	ENDIF
547	CALL nl_set_isoilwater ( grid%id , config_flags%isoilwater )
548	grid%isoilwater = config_flags%isoilwater
549
550	#ifdef MOVE_NESTS
551	! Added these fields for restarting of moving nests, JM
552	! DANGER and TODO
553	! It is very important that these be set correctly if they are set at all in here.
554	! Garbage values will produce unpredictable results, possibly segfaults, in the nesting
555	! code. Need some integrity checking here or elsewhere in the code to at least check to
556	! make sure that the istart and jstart values make sense with respect to the nest dimensions
557	! and the position in the parent domain.
558	CALL wrf_get_dom_ti_integer ( fid , 'I_PARENT_START' , itmp , 1 , icnt, ierr )
559	IF ( ierr .EQ. 0 .AND. switch .EQ. restart_only ) THEN
560	config_flags%i_parent_start = itmp
561	CALL nl_set_i_parent_start ( grid%id , config_flags%i_parent_start )
562	ENDIF
563	CALL wrf_get_dom_ti_integer ( fid , 'J_PARENT_START' , itmp , 1 , icnt, ierr )
564	IF ( ierr .EQ. 0 .AND. switch .EQ. restart_only ) THEN
565	config_flags%j_parent_start = itmp
566	CALL nl_set_j_parent_start ( grid%id , config_flags%j_parent_start )
567	ENDIF
568	#endif
569
570	#if (EM_CORE == 1)
571
572	!KLUDGE - is there a more elegant way to determine "old si" input
573	IF ( ( switch .EQ. input_only ) .OR. &
574	( ( switch .EQ. auxinput1_only ) .AND. &
575	( config_flags%auxinput1_inname(1:8) .EQ. 'wrf_real' ) ) ) THEN
576
577	! Test to make sure that the input data is the right size.
578
579	IF ( ( ide .NE. ide_compare ) .OR. &
580	( kde .NE. kde_compare ) .OR. &
581	( jde .NE. jde_compare ) ) THEN
582	WRITE(wrf_err_message,*)'input_wrf.F: SIZE MISMATCH: namelist ide,jde,kde=',ide,jde,kde,&
583	'; input data ide,jde,kde=',ide_compare , jde_compare , kde_compare
584	CALL wrf_error_fatal( wrf_err_message )
585	ENDIF
586
587	ELSE IF ( switch .EQ. auxinput1_only ) THEN
588
589	! Test to make sure that the input data is the right size.
590
591	IF ( ( ide .NE. ide_compare ) .OR. &
592	( config_flags%num_metgrid_levels .NE. kde_compare ) .OR. &
593	( jde .NE. jde_compare ) ) THEN
594	WRITE(wrf_err_message,*)'input_wrf.F: SIZE MISMATCH: ',&
595	'namelist ide,jde,num_metgrid_levels=',ide,jde,config_flags%num_metgrid_levels,&
596	'; input data ide,jde,num_metgrid_levels=',ide_compare , jde_compare , kde_compare
597	CALL wrf_error_fatal( wrf_err_message )
598	ENDIF
599	ENDIF
600
601	#endif
602
603	#if (NMM_CORE == 1)
604
605	IF ( ( switch .EQ. auxinput1_only ) .AND. &
606	( config_flags%auxinput1_inname(1:8) .EQ. 'wrf_real' ) ) THEN
607
608	CALL wrf_get_dom_ti_integer ( fid , 'BOTTOM-TOP_GRID_DIMSNSION' , kde_compare , 1 , icnt , ierr3 )
609
610	! Test to make sure that the input data is the right size.
611
612	IF ( ( ide-1 .NE. ide_compare ) .OR. &
613	( kde .NE. kde_compare ) .OR. &
614	( jde-1 .NE. jde_compare ) .AND. ierr3 .EQ. 0 ) THEN
615	WRITE(wrf_err_message,*)'input_wrf.F: SIZE MISMATCH: namelist ide-1,jde-1,kde=',ide-1,jde-1,kde,&
616	'; input data ide,jde,kde=',ide_compare , jde_compare , kde_compare
617	CALL wrf_debug( 100, wrf_err_message )
618	ENDIF
619
620	ELSEIF ( switch .EQ. auxinput1_only ) THEN ! assume just WPS in this branch
621	IF ( ( ide-1 .NE. ide_compare ) .OR. &
622	( config_flags%num_metgrid_levels .NE. kde_compare ) .OR. &
623	( jde-1 .NE. jde_compare ) .AND. ierr3 .EQ. 0 ) THEN
624	WRITE(wrf_err_message,*)'input_wrf.F: SIZE MISMATCH: ',&
625	'namelist ide-1,jde-1,num_metgrid_levels=',ide-1,jde-1,config_flags%num_metgrid_levels,&
626	'; input data ide,jde,num_metgrid_levels=',ide_compare , jde_compare , kde_compare
627	IF (ide-1 .eq. ide_compare .AND. jde-1 .EQ. jde_compare) THEN
628	CALL wrf_message(wrf_err_message)
629	CALL wrf_error_fatal( "appears that the vertical dimension is wrong - quitting" )
630	ELSE
631	CALL wrf_message(wrf_err_message)
632	CALL wrf_error_fatal( "appears that I or J dimensions are wrong - quitting" )
633	ENDIF
634	ENDIF
635	ENDIF
636
637	#endif
638
639	ENDIF check_if_dryrun
640
641	!
642	! This call to wrf_get_next_time will position the dataset over the next time-frame
643	! in the file and return the current_date, which is used as an argument to the
644	! read_field routines in the blocks of code included below. Note that we read the
645	! next time after all the meta data has been read. This is only important for the
646	! WRF internal I/O format because it is order-dependent. Other formats shouldn't care
647	! about this.
648	!
649
650	3003 continue
651
652	CALL wrf_get_next_time(fid, current_date , ierr)
653	WRITE(wrf_err_message,*)fid,' input_wrf: wrf_get_next_time current_date: ',current_date(1:19),' Status = ',ierr
654	CALL wrf_debug ( 300 , TRIM(wrf_err_message ) )
655	IF ( ierr .NE. 0 .AND. ierr .NE. WRF_WARN_NOTSUPPORTED .AND. ierr .NE. WRF_WARN_DRYRUN_READ ) THEN
656	CALL wrf_message ( TRIM(wrf_err_message ) )
657	IF ( switch .EQ. boundary_only ) THEN
658	WRITE(wrf_err_message,*) ' ... May have run out of valid boundary conditions in file ',TRIM(fname)
659	CALL wrf_error_fatal( TRIM(wrf_err_message) )
660	ELSE
661	#if ( NMM_CORE != 1 )
662	WRITE(wrf_err_message,*) '... Could not find matching time in input file ',TRIM(fname)
663	CALL wrf_error_fatal( TRIM(wrf_err_message) )
664	#endif
665	ENDIF
666	ELSE IF ( ierr .NE. WRF_WARN_NOTSUPPORTED .AND. ierr .NE. WRF_WARN_DRYRUN_READ) THEN
667	!
668	! check input time against domain time (which will be start time at beginning, see share/set_timekeeping.F)
669	! JM 20040511
670	!
671	SELECT CASE ( switch )
672	CASE ( input_only, auxinput1_only, auxinput2_only, &
673	auxinput3_only, auxinput4_only, auxinput5_only, &
674	auxinput6_only, auxinput7_only, auxinput8_only, &
675	auxinput9_only, auxinput10_only )
676	#ifdef WRF_CHEM
677	IF( (config_flags%io_style_emissions .eq. 1) .and. &
678	((switch.eq.auxinput5_only) .or. (switch.eq.auxinput6_only) .or. &
679	(switch.eq.auxinput7_only) .or. (switch.eq.auxinput8_only)) ) then
680	CALL wrf_message( "WARNING Time in input file not being checked WARNING" )
681	ELSE
682	#endif
683	CALL wrf_atotime( current_date(1:19), time )
684	CALL domain_clock_get( grid, current_time=currtime, &
685	current_timestr=currtimestr )
686	#if (DA_CORE != 1)
687	! Don't perform the check for WRFVAR, as we're not passing the right dates
688	! around
689	CALL domain_clockprint(150, grid, &
690	'DEBUG input_wrf(): get CurrTime from clock,')
691	IF ( time .NE. currtime ) THEN
692	WRITE( wrf_err_message , * )'Time in file: ',trim( current_date(1:19) )
693	CALL wrf_message ( trim(wrf_err_message) )
694	WRITE( wrf_err_message , * )'Time on domain: ',trim( currtimestr )
695	CALL wrf_message ( trim(wrf_err_message) )
696	CALL wrf_message( "WARNING Time in input file not equal to time on domain WARNING" )
697	WRITE(wrf_err_message,) "WARNING* Trying next time in file ",TRIM(fname)," ..."
698	CALL wrf_message( TRIM(wrf_err_message) )
699	GOTO 3003
700	ENDIF
701	#endif
702	#ifdef WRF_CHEM
703	ENDIF
704	#endif
705	CASE DEFAULT
706	END SELECT
707	ENDIF
708
709	! set the lbc time interval fields in the domain data structure
710	! these time values are checked as stopping condition for the while loop in
711	! latbound_in() defined in share/medation_integrate.F, which is used to
712	! iterate forward to the correct interval in the input LBC file
713	!
714	IF ( switch .EQ. boundary_only ) THEN
715	CALL domain_clock_get( grid, current_time=currentTime )
716	CALL wrf_get_dom_td_char ( fid , 'THISBDYTIME' , current_date(1:19), this_datestr , ierr )
717	CALL wrf_atotime( this_datestr(1:19), grid%this_bdy_time )
718	CALL wrf_get_dom_td_char ( fid , 'NEXTBDYTIME' , current_date(1:19), next_datestr , ierr )
719	CALL wrf_atotime( next_datestr(1:19), grid%next_bdy_time )
720	#if (DA_CORE != 1)
721	IF( currentTime .GE. grid%next_bdy_time ) THEN
722	IF ( wrf_dm_on_monitor() ) write(0,*) 'THIS TIME ',this_datestr(1:19),'NEXT TIME ',next_datestr(1:19)
723	RETURN
724	ENDIF
725	#endif
726	ENDIF
727
728	#if ( ( EM_CORE == 1 ) && ( DA_CORE != 1 ) )
729	! Vertical interpolation space is required if specified by user.
730
731	n_ref_m = config_flags%vert_refine_fact
732	#else
733	! Default value indicating no vertical interpolation required.
734
735	n_ref_m = 0
736	#endif
737
738	IF ( (first_input .LE. switch .AND. switch .LE. last_input) .OR. &
739	(first_history .LE. switch .AND. switch .LE. last_history) .OR. &
740	switch .EQ. restart_only ) THEN
741	newswitch = switch
742	p => grid%head_statevars%next
743	DO WHILE ( ASSOCIATED( p ) )
744	IF ( p%ProcOrient .NE. 'X' .AND. p%ProcOrient .NE. 'Y' ) THEN ! no I/O for xposed variables
745	IF ( p%Ndim .EQ. 0 ) THEN
746	IF ((p%Restart.AND.switch.EQ.restart_only).OR.on_stream( p%streams,newswitch)) THEN
747	IF ( in_use_for_config(grid%id,TRIM(p%VarName)) ) THEN
748	IF (p%Ntl.GT.0.AND.switch.NE.restart_only)dname=dname(1:len(TRIM(dname))-2)
749	dname = p%DataName
750	IF (switch.EQ.restart_only.OR.p%Ntl/100.EQ.mod(p%Ntl,100)) THEN
751	IF ( p%Type .EQ. 'r' ) THEN
752	CALL wrf_ext_read_field ( &
753	fid , & ! DataHandle
754	current_date(1:19) , & ! DateStr
755	TRIM(dname) , & ! Data Name
756	p%rfield_0d , & ! Field
757	WRF_FLOAT , & ! FieldType
758	grid%communicator , & ! Comm
759	grid%iocommunicator , & ! Comm
760	grid%domdesc , & ! Comm
761	grid%bdy_mask , & ! bdy_mask
762	'0' , & ! MemoryOrder
763	'' , & ! Stagger
764	__FILE__ // ' reading 0d real ' // TRIM(p%VarName) , & ! Debug message
765	1 , 1 , 1 , 1 , 1 , 1 , &
766	1 , 1 , 1 , 1 , 1 , 1 , &
767	1 , 1 , 1 , 1 , 1 , 1 , &
768	ierr )
769	ELSE IF ( p%Type .EQ. 'd' ) THEN
770	CALL wrf_ext_read_field ( &
771	fid , & ! DataHandle
772	current_date(1:19) , & ! DateStr
773	TRIM(dname) , & ! Data Name
774	p%dfield_0d , & ! Field
775	WRF_DOUBLE , & ! FieldType
776	grid%communicator , & ! Comm
777	grid%iocommunicator , & ! Comm
778	grid%domdesc , & ! Comm
779	grid%bdy_mask , & ! bdy_mask
780	'0' , & ! MemoryOrder
781	'' , & ! Stagger
782	__FILE__ // ' reading 0d double ' // TRIM(p%VarName) , & ! Debug message
783	1 , 1 , 1 , 1 , 1 , 1 , &
784	1 , 1 , 1 , 1 , 1 , 1 , &
785	1 , 1 , 1 , 1 , 1 , 1 , &
786	ierr )
787	ELSE IF ( p%Type .EQ. 'i' ) THEN
788	CALL wrf_ext_read_field ( &
789	fid , & ! DataHandle
790	current_date(1:19) , & ! DateStr
791	TRIM(dname) , & ! Data Name
792	p%ifield_0d , & ! Field
793	WRF_INTEGER , & ! FieldType
794	grid%communicator , & ! Comm
795	grid%iocommunicator , & ! Comm
796	grid%domdesc , & ! Comm
797	grid%bdy_mask , & ! bdy_mask
798	'0' , & ! MemoryOrder
799	'' , & ! Stagger
800	__FILE__ // ' reading 0d integer ' // TRIM(p%VarName) , & ! Debug message
801	1 , 1 , 1 , 1 , 1 , 1 , &
802	1 , 1 , 1 , 1 , 1 , 1 , &
803	1 , 1 , 1 , 1 , 1 , 1 , &
804	ierr )
805	ELSE IF ( p%Type .EQ. 'l' ) THEN
806	CALL wrf_ext_read_field ( &
807	fid , & ! DataHandle
808	current_date(1:19) , & ! DateStr
809	TRIM(dname) , & ! Data Name
810	p%lfield_0d , & ! Field
811	WRF_LOGICAL , & ! FieldType
812	grid%communicator , & ! Comm
813	grid%iocommunicator , & ! Comm
814	grid%domdesc , & ! Comm
815	grid%bdy_mask , & ! bdy_mask
816	'0' , & ! MemoryOrder
817	'' , & ! Stagger
818	__FILE__ // ' reading 0d logical ' // TRIM(p%VarName) , & ! Debug message
819	1 , 1 , 1 , 1 , 1 , 1 , &
820	1 , 1 , 1 , 1 , 1 , 1 , &
821	1 , 1 , 1 , 1 , 1 , 1 , &
822	ierr )
823	ENDIF
824	ENDIF
825	ENDIF
826	ENDIF
827	ELSE IF ( p%Ndim .EQ. 1 ) THEN
828	IF ((p%Restart.AND.switch.EQ.restart_only).OR.on_stream( p%streams,newswitch)) THEN
829	IF ( in_use_for_config(grid%id,TRIM(p%VarName)) ) THEN
830	IF (switch.EQ.restart_only.OR.p%Ntl/100.EQ.mod(p%Ntl,100)) THEN
831	dname = p%DataName
832	IF (p%Ntl.GT.0.AND.switch.NE.restart_only)dname=dname(1:len(TRIM(dname))-2)
833	memord = p%MemoryOrder
834
835	i_inter = 0
836	#if ( ( EM_CORE == 1 ) && ( DA_CORE != 1 ) )
837	! Vertical interpolation space is required if specified by user.
838
839	if( TRIM(p%dimname1).EQ.'bottom_top'.OR.TRIM(p%dimname1).EQ.'bottom_top_stag') i_inter = 1
840	#endif
841
842	IF ( p%Type .EQ. 'r' ) THEN
843	IF( (i_inter.eq.1.and.n_ref_m.ge.2).and.(switch.eq.history_only) ) THEN
844	em1_c = (p%em1 - 1)/n_ref_m +1
845	ed1_c = em1_c
846	ep1_c = em1_c
847	if (TRIM(p%dimname1).EQ.'bottom_top') then
848	ed1_c = em1_c-1
849	ep1_c = em1_c-1
850	endif
851	allocate (f_vint_1d(em1_c))
852
853	CALL wrf_ext_read_field ( &
854	fid , & ! DataHandle
855	current_date(1:19) , & ! DateStr
856	TRIM(dname) , & ! Data Name
857	f_vint_1d , & ! Field
858	WRF_FLOAT , & ! FieldType
859	grid%communicator , & ! Comm
860	grid%iocommunicator , & ! Comm
861	grid%domdesc , & ! Comm
862	grid%bdy_mask , & ! bdy_mask
863	TRIM(memord) , & ! MemoryOrder
864	p%Stagger , & ! Stagger
865	__FILE__ // ' reading 1d real ' // TRIM(p%VarName) , & ! Debug message
866	p%sd1 , ed1_c , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
867	p%sm1 , em1_c , p%sm2 , p%em2 , p%sm3 , p%em3 , &
868	p%sp1 , ep1_c , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
869	ierr )
870
871	do k=1,ed1_c
872	p%rfield_1d(k) = f_vint_1d(k)
873	enddo
874	deallocate (f_vint_1d)
875
876	ELSE
877	CALL wrf_ext_read_field ( &
878	fid , & ! DataHandle
879	current_date(1:19) , & ! DateStr
880	TRIM(dname) , & ! Data Name
881	p%rfield_1d , & ! Field
882	WRF_FLOAT , & ! FieldType
883	grid%communicator , & ! Comm
884	grid%iocommunicator , & ! Comm
885	grid%domdesc , & ! Comm
886	grid%bdy_mask , & ! bdy_mask
887	TRIM(memord) , & ! MemoryOrder
888	p%Stagger , & ! Stagger
889	__FILE__ // ' reading 1d real ' // TRIM(p%VarName) , & ! Debug message
890	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
891	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
892	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
893	ierr )
894	END IF
895	ELSE IF ( p%Type .EQ. 'd' ) THEN
896	CALL wrf_ext_read_field ( &
897	fid , & ! DataHandle
898	current_date(1:19) , & ! DateStr
899	TRIM(dname) , & ! Data Name
900	p%dfield_1d , & ! Field
901	WRF_DOUBLE , & ! FieldType
902	grid%communicator , & ! Comm
903	grid%iocommunicator , & ! Comm
904	grid%domdesc , & ! Comm
905	grid%bdy_mask , & ! bdy_mask
906	TRIM(memord) , & ! MemoryOrder
907	TRIM(p%Stagger) , & ! Stagger
908	__FILE__ // ' reading 1d double ' // TRIM(p%VarName) , & ! Debug message
909	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
910	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
911	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
912	ierr )
913	ELSE IF ( p%Type .EQ. 'i' ) THEN
914	CALL wrf_ext_read_field ( &
915	fid , & ! DataHandle
916	current_date(1:19) , & ! DateStr
917	TRIM(dname) , & ! Data Name
918	p%ifield_1d , & ! Field
919	WRF_INTEGER , & ! FieldType
920	grid%communicator , & ! Comm
921	grid%iocommunicator , & ! Comm
922	grid%domdesc , & ! Comm
923	grid%bdy_mask , & ! bdy_mask
924	TRIM(memord) , & ! MemoryOrder
925	TRIM(p%Stagger) , & ! Stagger
926	__FILE__ // ' reading 1d integer ' // TRIM(p%VarName) , & ! Debug message
927	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
928	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
929	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
930	ierr )
931	ELSE IF ( p%Type .EQ. 'l' ) THEN
932	CALL wrf_ext_read_field ( &
933	fid , & ! DataHandle
934	current_date(1:19) , & ! DateStr
935	TRIM(dname) , & ! Data Name
936	p%lfield_1d , & ! Field
937	WRF_LOGICAL , & ! FieldType
938	grid%communicator , & ! Comm
939	grid%iocommunicator , & ! Comm
940	grid%domdesc , & ! Comm
941	grid%bdy_mask , & ! bdy_mask
942	TRIM(memord) , & ! MemoryOrder
943	TRIM(p%Stagger) , & ! Stagger
944	__FILE__ // ' reading 1d logical ' // TRIM(p%VarName) , & ! Debug message
945	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
946	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
947	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
948	ierr )
949	ENDIF
950	ENDIF
951	ENDIF
952	ENDIF
953	ELSE IF ( p%Ndim .EQ. 2 ) THEN
954	IF ((p%Restart.AND.switch.EQ.restart_only).OR.on_stream( p%streams,newswitch)) THEN
955	IF ( in_use_for_config(grid%id,TRIM(p%VarName)) .AND. &
956	( .NOT. p%subgrid_x .OR. (p%subgrid_x .AND. grid%sr_x .GT. 0) ) .AND. &
957	( .NOT. p%subgrid_y .OR. (p%subgrid_y .AND. grid%sr_y .GT. 0) ) &
958	) THEN
959	IF (switch.EQ.restart_only.OR.p%Ntl/100.EQ.mod(p%Ntl,100)) THEN
960	dname = p%DataName
961	IF (p%Ntl.GT.0.AND.switch.NE.restart_only)dname=dname(1:len(TRIM(dname))-2)
962	memord = p%MemoryOrder
963	IF ( p%Type .EQ. 'r' ) THEN
964	CALL wrf_ext_read_field ( &
965	fid , & ! DataHandle
966	current_date(1:19) , & ! DateStr
967	TRIM(dname) , & ! Data Name
968	p%rfield_2d , & ! Field
969	WRF_FLOAT , & ! FieldType
970	grid%communicator , & ! Comm
971	grid%iocommunicator , & ! Comm
972	grid%domdesc , & ! Comm
973	grid%bdy_mask , & ! bdy_mask
974	TRIM(memord) , & ! MemoryOrder
975	TRIM(p%Stagger) , & ! Stagger
976	__FILE__ // ' reading 2d real ' // TRIM(p%VarName) , & ! Debug message
977	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
978	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
979	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
980	ierr )
981	ELSE IF ( p%Type .EQ. 'd' ) THEN
982	CALL wrf_ext_read_field ( &
983	fid , & ! DataHandle
984	current_date(1:19) , & ! DateStr
985	TRIM(dname) , & ! Data Name
986	p%dfield_2d , & ! Field
987	WRF_DOUBLE , & ! FieldType
988	grid%communicator , & ! Comm
989	grid%iocommunicator , & ! Comm
990	grid%domdesc , & ! Comm
991	grid%bdy_mask , & ! bdy_mask
992	TRIM(memord) , & ! MemoryOrder
993	TRIM(p%Stagger) , & ! Stagger
994	__FILE__ // ' reading 2d double ' // TRIM(p%VarName) , & ! Debug message
995	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
996	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
997	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
998	ierr )
999	ELSE IF ( p%Type .EQ. 'i' ) THEN
1000	CALL wrf_ext_read_field ( &
1001	fid , & ! DataHandle
1002	current_date(1:19) , & ! DateStr
1003	TRIM(dname) , & ! Data Name
1004	p%ifield_2d , & ! Field
1005	WRF_INTEGER , & ! FieldType
1006	grid%communicator , & ! Comm
1007	grid%iocommunicator , & ! Comm
1008	grid%domdesc , & ! Comm
1009	grid%bdy_mask , & ! bdy_mask
1010	TRIM(memord) , & ! MemoryOrder
1011	TRIM(p%Stagger) , & ! Stagger
1012	__FILE__ // ' reading 2d integer ' // TRIM(p%VarName) , & ! Debug message
1013	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1014	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1015	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1016	ierr )
1017	ELSE IF ( p%Type .EQ. 'l' ) THEN
1018	CALL wrf_ext_read_field ( &
1019	fid , & ! DataHandle
1020	current_date(1:19) , & ! DateStr
1021	TRIM(dname) , & ! Data Name
1022	p%lfield_2d , & ! Field
1023	WRF_LOGICAL , & ! FieldType
1024	grid%communicator , & ! Comm
1025	grid%iocommunicator , & ! Comm
1026	grid%domdesc , & ! Comm
1027	grid%bdy_mask , & ! bdy_mask
1028	TRIM(memord) , & ! MemoryOrder
1029	TRIM(p%Stagger) , & ! Stagger
1030	__FILE__ // ' reading 2d logical ' // TRIM(p%VarName) , & ! Debug message
1031	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1032	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1033	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1034	ierr )
1035	ENDIF
1036	ENDIF
1037	ENDIF
1038	ENDIF
1039	ELSE IF ( p%Ndim .EQ. 3 ) THEN
1040	IF ((p%Restart.AND.switch.EQ.restart_only).OR.on_stream( p%streams,newswitch)) THEN
1041	IF ( in_use_for_config(grid%id,TRIM(p%VarName)) .AND. &
1042	( .NOT. p%subgrid_x .OR. (p%subgrid_x .AND. grid%sr_x .GT. 0) ) .AND. &
1043	( .NOT. p%subgrid_y .OR. (p%subgrid_y .AND. grid%sr_y .GT. 0) ) &
1044	) THEN
1045	IF (switch.EQ.restart_only.OR.p%Ntl/100.EQ.mod(p%Ntl,100)) THEN
1046	dname = p%DataName
1047	IF (p%Ntl.GT.0.AND.switch.NE.restart_only)dname=dname(1:len(TRIM(dname))-2)
1048	memord = p%MemoryOrder
1049
1050	i_inter = 0
1051	#if ( ( EM_CORE == 1 ) && ( DA_CORE != 1 ) )
1052	! Vertical interpolation space is required if specified by user.
1053
1054	if( TRIM(p%dimname2).EQ.'bottom_top'.OR.TRIM(p%dimname2).EQ.'bottom_top_stag') i_inter = 1
1055	#endif
1056
1057	IF ( p%Type .EQ. 'r' ) THEN
1058	IF( (i_inter.eq.1.and.n_ref_m.ge.2).and.(switch.eq.history_only) ) then
1059	em2_c = (p%em2 - 1)/n_ref_m +1
1060	ed2_c = em2_c
1061	ep2_c = em2_c
1062	if (TRIM(p%dimname2).EQ.'bottom_top') then
1063	ed2_c = em2_c-1
1064	ep2_c = em2_c-1
1065	endif
1066	allocate (f_vint_3d(p%sm1:p%em1,em2_c,p%sm3:p%em3))
1067	CALL wrf_ext_read_field ( &
1068	fid , & ! DataHandle
1069	current_date(1:19) , & ! DateStr
1070	TRIM(dname) , & ! Data Name
1071	f_vint_3d , & ! Field
1072	WRF_FLOAT , & ! FieldType
1073	grid%communicator , & ! Comm
1074	grid%iocommunicator , & ! Comm
1075	grid%domdesc , & ! Comm
1076	grid%bdy_mask , & ! bdy_mask
1077	TRIM(memord) , & ! MemoryOrder
1078	TRIM(p%Stagger) , & ! Stagger
1079	__FILE__ // ' reading 3d real ' // TRIM(p%VarName) , & ! Debug message
1080	p%sd1 , p%ed1 , p%sd2 , ed2_c , p%sd3 , p%ed3 , &
1081	p%sm1 , p%em1 , p%sm2 , em2_c , p%sm3 , p%em3 , &
1082	p%sp1 , p%ep1 , p%sp2 , ep2_c , p%sp3 , p%ep3 , &
1083	ierr )
1084
1085	do j = p%sm3,p%em3
1086	do k = 1,ed2_c
1087	do i = p%sm1,p%em1
1088	p%rfield_3d(i,k,j) = f_vint_3d(i,k,j)
1089	enddo
1090	enddo
1091	enddo
1092	deallocate (f_vint_3d)
1093	ELSE
1094	CALL wrf_ext_read_field ( &
1095	fid , & ! DataHandle
1096	current_date(1:19) , & ! DateStr
1097	TRIM(dname) , & ! Data Name
1098	p%rfield_3d , & ! Field
1099	WRF_FLOAT , & ! FieldType
1100	grid%communicator , & ! Comm
1101	grid%iocommunicator , & ! Comm
1102	grid%domdesc , & ! Comm
1103	grid%bdy_mask , & ! bdy_mask
1104	TRIM(memord) , & ! MemoryOrder
1105	TRIM(p%Stagger) , & ! Stagger
1106	__FILE__ // ' reading 3d real ' // TRIM(p%VarName) , & ! Debug message
1107	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1108	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1109	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1110	ierr )
1111	ENDIF
1112	ELSE IF ( p%Type .EQ. 'd' ) THEN
1113	CALL wrf_ext_read_field ( &
1114	fid , & ! DataHandle
1115	current_date(1:19) , & ! DateStr
1116	TRIM(dname) , & ! Data Name
1117	p%dfield_3d , & ! Field
1118	WRF_DOUBLE , & ! FieldType
1119	grid%communicator , & ! Comm
1120	grid%iocommunicator , & ! Comm
1121	grid%domdesc , & ! Comm
1122	grid%bdy_mask , & ! bdy_mask
1123	TRIM(memord) , & ! MemoryOrder
1124	TRIM(p%Stagger) , & ! Stagger
1125	__FILE__ // ' reading 3d double ' // TRIM(p%VarName) , & ! Debug message
1126	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1127	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1128	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1129	ierr )
1130	ELSE IF ( p%Type .EQ. 'i' ) THEN
1131	CALL wrf_ext_read_field ( &
1132	fid , & ! DataHandle
1133	current_date(1:19) , & ! DateStr
1134	TRIM(dname) , & ! Data Name
1135	p%ifield_3d , & ! Field
1136	WRF_INTEGER , & ! FieldType
1137	grid%communicator , & ! Comm
1138	grid%iocommunicator , & ! Comm
1139	grid%domdesc , & ! Comm
1140	grid%bdy_mask , & ! bdy_mask
1141	TRIM(memord) , & ! MemoryOrder
1142	TRIM(p%Stagger) , & ! Stagger
1143	__FILE__ // ' reading 3d integer ' // TRIM(p%VarName) , & ! Debug message
1144	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1145	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1146	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1147	ierr )
1148	! NOTE no io on logical arrays greater than 2d
1149	ENDIF
1150	ENDIF
1151	ENDIF
1152	ENDIF
1153	ELSE IF ( p%Ndim .EQ. 4 .AND. p%scalar_array ) THEN
1154	! Use a different read routine, wrf_ext_read_field_arr, and pass in the
1155	! tracer indeces so that p%rfield_4d can be passsed in without arguments,
1156	! avoiding the possiblity of a copy-in/copy-out problem for some compilers.
1157	! JM 20091208
1158	DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id)
1159	IF ((p%Restart.AND.switch.EQ.restart_only).OR.on_stream( p%streams_table(grid%id,itrace)%stream,newswitch)) THEN
1160	dname = p%dname_table( grid%id, itrace )
1161	IF (p%Ntl.GT.0.AND.switch.NE.restart_only)dname=dname(1:len(TRIM(dname))-2)
1162	memord = p%MemoryOrder
1163
1164	i_inter = 0
1165	#if ( ( EM_CORE == 1 ) && ( DA_CORE != 1 ) )
1166	! Vertical interpolation space is required if specified by user.
1167
1168	if( TRIM(p%dimname2).EQ.'bottom_top'.OR.TRIM(p%dimname2).EQ.'bottom_top_stag') i_inter = 1
1169	#endif
1170
1171	IF ( p%Type .EQ. 'r' ) THEN
1172	IF( (i_inter.eq.1.and.n_ref_m.ge.2).and.(switch.eq.history_only) ) then
1173	em2_c = (p%em2 - 1)/n_ref_m +1
1174	ed2_c = em2_c
1175	ep2_c = em2_c
1176	if (TRIM(p%dimname2).EQ.'bottom_top') then
1177	ed2_c = em2_c-1
1178	ep2_c = em2_c-1
1179	endif
1180	allocate (f_vint_4d(p%sm1:p%em1,em2_c,p%sm3:p%em3,p%num_table(grid%id)))
1181
1182	CALL wrf_ext_read_field_arr ( &
1183	fid , & ! DataHandle
1184	current_date(1:19) , & ! DateStr
1185	TRIM(dname) , & ! Data Name
1186	f_vint_4d , & ! Field
1187	itrace, 1, 1, 1 , & ! see comment above
1188	1, 1, 1 , & ! see comment above
1189	RWORDSIZE , &
1190	WRF_FLOAT , & ! FieldType
1191	grid%communicator , & ! Comm
1192	grid%iocommunicator , & ! Comm
1193	grid%domdesc , & ! Comm
1194	grid%bdy_mask , & ! bdy_mask
1195	TRIM(memord) , & ! MemoryOrder
1196	TRIM(p%Stagger) , & ! Stagger
1197	__FILE__ // ' reading 4d real ' // TRIM(p%dname_table(grid%id,itrace)) , & ! Debug message
1198	p%sd1 , p%ed1 , p%sd2 , ed2_c , p%sd3 , p%ed3 , &
1199	p%sm1 , p%em1 , p%sm2 , em2_c , p%sm3 , p%em3 , &
1200	p%sp1 , p%ep1 , p%sp2 , ep2_c , p%sp3 , p%ep3 , &
1201	ierr )
1202	do j = p%sm3,p%em3
1203	do k = 1,ed2_c
1204	do i = p%sm1,p%em1
1205	p%rfield_4d(i,k,j,itrace) = f_vint_4d(i,k,j,itrace)
1206	enddo
1207	enddo
1208	enddo
1209	deallocate (f_vint_4d)
1210	ELSE
1211	CALL wrf_ext_read_field_arr ( &
1212	fid , & ! DataHandle
1213	current_date(1:19) , & ! DateStr
1214	TRIM(dname) , & ! Data Name
1215	p%rfield_4d , & ! Field
1216	itrace, 1, 1, 1 , & ! see comment above
1217	1, 1, 1 , & ! see comment above
1218	RWORDSIZE , &
1219	WRF_FLOAT , & ! FieldType
1220	grid%communicator , & ! Comm
1221	grid%iocommunicator , & ! Comm
1222	grid%domdesc , & ! Comm
1223	grid%bdy_mask , & ! bdy_mask
1224	TRIM(memord) , & ! MemoryOrder
1225	TRIM(p%Stagger) , & ! Stagger
1226	__FILE__ // ' reading 4d real ' // TRIM(p%dname_table(grid%id,itrace)) , & ! Debug message
1227	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1228	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1229	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1230	ierr )
1231	ENDIF
1232	ELSE IF ( p%Type .EQ. 'd' ) THEN
1233	CALL wrf_ext_read_field_arr ( &
1234	fid , & ! DataHandle
1235	current_date(1:19) , & ! DateStr
1236	TRIM(dname) , & ! Data Name
1237	p%dfield_4d , & ! Field
1238	itrace, 1, 1, 1 , & ! see comment above
1239	1, 1, 1 , & ! see comment above
1240	DWORDSIZE , &
1241	WRF_DOUBLE , & ! FieldType
1242	grid%communicator , & ! Comm
1243	grid%iocommunicator , & ! Comm
1244	grid%domdesc , & ! Comm
1245	grid%bdy_mask , & ! bdy_mask
1246	TRIM(memord) , & ! MemoryOrder
1247	TRIM(p%Stagger) , & ! Stagger
1248	__FILE__ // ' reading 4d double ' // TRIM(p%dname_table(grid%id,itrace)) , & ! Debug message
1249	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1250	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1251	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1252	ierr )
1253	ELSE IF ( p%Type .EQ. 'i' ) THEN
1254	CALL wrf_ext_read_field_arr ( &
1255	fid , & ! DataHandle
1256	current_date(1:19) , & ! DateStr
1257	TRIM(dname) , & ! Data Name
1258	p%ifield_4d , & ! Field
1259	itrace, 1, 1, 1 , & ! see comment above
1260	1, 1, 1 , & ! see comment above
1261	IWORDSIZE , &
1262	WRF_INTEGER , & ! FieldType
1263	grid%communicator , & ! Comm
1264	grid%iocommunicator , & ! Comm
1265	grid%domdesc , & ! Comm
1266	grid%bdy_mask , & ! bdy_mask
1267	TRIM(memord) , & ! MemoryOrder
1268	TRIM(p%Stagger) , & ! Stagger
1269	__FILE__ // ' reading 4d integer ' // TRIM(p%dname_table(grid%id,itrace)) , & ! Debug message
1270	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1271	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1272	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1273	ierr )
1274	ENDIF
1275	ENDIF
1276	ENDDO ! loop over tracers
1277	ENDIF
1278	ENDIF
1279	p => p%next
1280	ENDDO
1281	ELSE
1282	IF ( switch .EQ. boundary_only ) THEN
1283	CALL wrf_bdyin( fid , grid , config_flags , switch , ierr )
1284	ENDIF
1285	ENDIF
1286
1287	#if (DA_CORE != 1)
1288	CALL wrf_tsin( grid , ierr )
1289	#endif
1290
1291	WRITE(wrf_err_message,*)'input_wrf: end, fid = ',fid
1292	CALL wrf_debug( 300 , wrf_err_message )
1293
1294	RETURN
1295	END SUBROUTINE input_wrf

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

Download in other formats:

Original Format