| blob | 7db2744eefe42f95abba0a077d084afd63c39183 |
1 !WRF:MEDIATION:IO
2 ! ---principal wrf input routine (called from routines in module_io_domain )
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
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
27 TYPE( fieldlist ), POINTER :: p
29 INTEGER newswitch, itrace
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
75 ! Local variables for vertical interpolation.
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
84 ! Local variables for the alarms in the input restart file.
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
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>
101 WRITE(wrf_err_message,*)'input_wrf: begin, fid = ',fid
102 CALL wrf_debug( 300 , wrf_err_message )
104 CALL modify_io_masks ( grid%id ) ! this adjusts the I/O masks according to the users run-time specs, if any
106 ierr = 0
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 )
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
120 WRITE(wrf_err_message,*)'input_wrf: fid,filestate = ',fid,filestate
121 CALL wrf_debug( 300 , wrf_err_message )
123 dryrun = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED )
125 WRITE(wrf_err_message,*)'input_wrf: dryrun = ',dryrun,' switch ',switch
126 CALL wrf_debug( 300 , wrf_err_message )
128 check_if_dryrun : IF ( .NOT. dryrun ) THEN
130 ! simulation start time is a Singleton maintained by head_grid
131 IF ( ( switch .EQ. input_only ) .OR. &
132 ( switch .EQ. restart_only ) ) THEN
134 IF ( switch .EQ. restart_only .AND. .NOT. config_flags%override_restart_timers ) THEN
135 ! recover the restart alarms from input if avialable
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 )
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
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 )
161 ENDIF
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
172 ENDIF
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
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.
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' )
265 #if (EM_CORE == 1)
266 ! Test to make sure that the grid distances are the right size.
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
286 ! do the check later (see check_if_dryrun below)
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.
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 )
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 )
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
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 )
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 )
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 )
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 )
331 #if ( NMM_CORE != 1 )
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 )
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 )
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.
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
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 )
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 )
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
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
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 )
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
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
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.
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 )
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
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
452 #if 0
453 #ifdef WRF_CHEM
454 ! Dust erosion static data.
456 CALL wrf_get_dom_ti_integer ( fid, 'EROSION_DIM', itmp, 1, icnt, ierr )
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
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
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
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
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
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
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
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
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
570 #if (EM_CORE == 1)
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
577 ! Test to make sure that the input data is the right size.
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
587 ELSE IF ( switch .EQ. auxinput1_only ) THEN
589 ! Test to make sure that the input data is the right size.
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
601 #endif
603 #if (NMM_CORE == 1)
605 IF ( ( switch .EQ. auxinput1_only ) .AND. &
606 ( config_flags%auxinput1_inname(1:8) .EQ. 'wrf_real' ) ) THEN
608 CALL wrf_get_dom_ti_integer ( fid , 'BOTTOM-TOP_GRID_DIMSNSION' , kde_compare , 1 , icnt , ierr3 )
610 ! Test to make sure that the input data is the right size.
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
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
637 #endif
639 ENDIF check_if_dryrun
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 !
650 3003 continue
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
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
728 #if ( ( EM_CORE == 1 ) && ( DA_CORE != 1 ) )
729 ! Vertical interpolation space is required if specified by user.
731 n_ref_m = config_flags%vert_refine_fact
732 #else
733 ! Default value indicating no vertical interpolation required.
735 n_ref_m = 0
736 #endif
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
835 i_inter = 0
836 #if ( ( EM_CORE == 1 ) && ( DA_CORE != 1 ) )
837 ! Vertical interpolation space is required if specified by user.
839 if( TRIM(p%dimname1).EQ.'bottom_top'.OR.TRIM(p%dimname1).EQ.'bottom_top_stag') i_inter = 1
840 #endif
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))
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 )
871 do k=1,ed1_c
872 p%rfield_1d(k) = f_vint_1d(k)
873 enddo
874 deallocate (f_vint_1d)
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
1050 i_inter = 0
1051 #if ( ( EM_CORE == 1 ) && ( DA_CORE != 1 ) )
1052 ! Vertical interpolation space is required if specified by user.
1054 if( TRIM(p%dimname2).EQ.'bottom_top'.OR.TRIM(p%dimname2).EQ.'bottom_top_stag') i_inter = 1
1055 #endif
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 )
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
1164 i_inter = 0
1165 #if ( ( EM_CORE == 1 ) && ( DA_CORE != 1 ) )
1166 ! Vertical interpolation space is required if specified by user.
1168 if( TRIM(p%dimname2).EQ.'bottom_top'.OR.TRIM(p%dimname2).EQ.'bottom_top_stag') i_inter = 1
1169 #endif
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)))
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
1287 #if (DA_CORE != 1)
1288 CALL wrf_tsin( grid , ierr )
1289 #endif
1291 WRITE(wrf_err_message,*)'input_wrf: end, fid = ',fid
1292 CALL wrf_debug( 300 , wrf_err_message )
1294 RETURN
1295 END SUBROUTINE input_wrf