| blob | 76631def2c216ec1440965685848ce5b64e5401f |
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
14 IMPLICIT NONE
15 #include "wrf_io_flags.h"
16 #include "wrf_status_codes.h"
17 TYPE(domain) :: grid
18 TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags
19 INTEGER, INTENT(IN) :: fid
20 INTEGER, INTENT(IN) :: switch
21 INTEGER, INTENT(INOUT) :: ierr
23 ! Local data
24 INTEGER ids , ide , jds , jde , kds , kde , &
25 ims , ime , jms , jme , kms , kme , &
26 ips , ipe , jps , jpe , kps , kpe
28 TYPE( fieldlist ), POINTER :: p
30 INTEGER newswitch, itrace
32 INTEGER iname(9)
33 INTEGER iordering(3)
34 INTEGER icurrent_date(24)
35 INTEGER i,j,k
36 INTEGER icnt
37 INTEGER ndim
38 INTEGER ilen
39 INTEGER , DIMENSION(3) :: domain_start , domain_end
40 INTEGER , DIMENSION(3) :: memory_start , memory_end
41 INTEGER , DIMENSION(3) :: patch_start , patch_end
42 CHARACTER*256 errmess, currtimestr
43 CHARACTER*40 :: this_datestr, next_datestr
44 CHARACTER*9 NAMESTR
45 INTEGER IBDY, NAMELEN
46 LOGICAL wrf_dm_on_monitor
47 EXTERNAL wrf_dm_on_monitor
48 Type(WRFU_Time) time, currtime, currentTime
49 CHARACTER*19 new_date
50 CHARACTER*24 base_date
51 CHARACTER*256 fname, version_name
52 CHARACTER*80 dname, memord, sim_type
53 LOGICAL dryrun
54 INTEGER idt
55 INTEGER itmp
56 INTEGER filestate, ierr3
57 INTEGER hybrid_opt, use_theta_m
58 INTEGER :: ide_compare , jde_compare , kde_compare
59 CHARACTER (len=19) simulation_start_date , first_date_input , first_date_nml
60 INTEGER first_date_start_year , &
61 first_date_start_month , &
62 first_date_start_day , &
63 first_date_start_hour , &
64 first_date_start_minute , &
65 first_date_start_second
66 INTEGER simulation_start_year , &
67 simulation_start_month , &
68 simulation_start_day , &
69 simulation_start_hour , &
70 simulation_start_minute , &
71 simulation_start_second
72 LOGICAL reset_simulation_start
73 REAL dx_compare , dy_compare , dum
74 INTEGER :: num_land_cat_compare
75 CHARACTER (LEN=256) :: MMINLU
77 ! Local variables for vertical interpolation.
79 REAL, ALLOCATABLE, DIMENSION(: ) :: f_vint_1d
80 REAL, ALLOCATABLE, DIMENSION(:,:,: ) :: f_vint_3d
81 REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: f_vint_4d
82 integer :: ed1_c,em1_c,ep1_c
83 integer :: ed2_c,em2_c,ep2_c
84 integer :: n_ref_m,i_inter
86 ! Local variables for the alarms in the input restart file.
88 INTEGER max_wrf_alarms_compare, seconds
89 CHARACTER*80 alarmname, timestr
90 TYPE(WRFU_Time) :: curtime, ringTime
91 TYPE(WRFU_TimeInterval) :: interval, interval2
92 integer s, iring
94 ! Local variables: are we are using the correct hypsometric option for ARW ideal cases.
96 CHARACTER (LEN=256) :: input_name
97 INTEGER :: loop, hypsometric_opt, icount
99 CHARACTER (LEN=256) :: a_message
101 ! Bundle up the fatal errors in one piece at the end of the file.
103 INTEGER :: count_fatal_error
105 ! Make sure that the input data is consistent with the current code.
107 LOGICAL :: yes_use_this_data
109 CHARACTER(10) :: check_which_switch
110 CHARACTER(10) :: my_string
113 !<DESCRIPTION>
114 !
115 ! Core wrf input routine for all input data streams. Part of mediation layer.
116 !
117 ! Note that WRF IOAPI routines wrf_get_dom_ti_*() do not return values during
118 ! training reads (dryrun).
119 !
120 !</DESCRIPTION>
122 WRITE(wrf_err_message,*)'input_wrf: begin'
123 CALL wrf_debug( 300 , wrf_err_message )
125 CALL modify_io_masks ( grid%id ) ! this adjusts the I/O masks according to the users run-time specs, if any
127 ! Initializations for error checking
129 ierr = 0
130 count_fatal_error = 0
133 CALL get_ijk_from_grid ( grid , &
134 ids, ide, jds, jde, kds, kde, &
135 ims, ime, jms, jme, kms, kme, &
136 ips, ipe, jps, jpe, kps, kpe )
138 ! If this was not a training read (dry run) check for erroneous values.
139 CALL wrf_inquire_filename ( fid , fname , filestate , ierr )
140 IF ( ierr /= 0 ) THEN
141 WRITE(wrf_err_message,*)'---- ERROR: module_io_wrf: input_wrf: wrf_inquire_filename Status = ',ierr
142 CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
143 count_fatal_error = count_fatal_error + 1
144 ENDIF
146 WRITE(wrf_err_message,*)'input_wrf: filestate = ',filestate
147 CALL wrf_debug( 300 , wrf_err_message )
149 dryrun = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED )
151 WRITE(wrf_err_message,*)'input_wrf: dryrun = ',dryrun,' switch ',switch
152 CALL wrf_debug( 300 , wrf_err_message )
154 check_if_dryrun : IF ( .NOT. dryrun ) THEN
156 #if ( ( EM_CORE == 1 ) && ( DA_CORE != 1 ) )
157 IF ( switch .EQ. boundary_only ) THEN
158 grid%just_read_boundary = .true.
159 END IF
160 #endif
162 IF ( .NOT. dryrun ) THEN
164 ! Does this file exist?
166 CALL wrf_inquire_filename ( fid , fname , filestate , ierr )
167 IF ( ( filestate .EQ. WRF_FILE_NOT_OPENED ) .OR. &
168 ( filestate .EQ. WRF_FILE_OPENED_FOR_WRITE ) ) THEN
169 my_string = check_which_switch(switch)
170 CALL wrf_error_fatal( 'Possibly missing file for = ' // TRIM(my_string) )
171 END IF
173 ! Determine is the input file we are reading is acceptable given the
174 ! assumptions about the current version of the modeling system.
176 CALL is_this_data_ok_to_use ( fid , yes_use_this_data )
177 IF ( ( yes_use_this_data ) .OR. ( config_flags%force_use_old_data ) ) THEN
178 WRITE(wrf_err_message,*)'Input data is acceptable to use: ' // TRIM(fname)
179 CALL wrf_debug( 0 , wrf_err_message )
180 ELSE
181 CALL wrf_debug( 0 , 'File name that is causing troubles = ' // TRIM(fname) )
182 WRITE(wrf_err_message,*)'You can try 1) ensure that the input file was created with WRF v4 pre-processors, or '
183 CALL wrf_debug( 0 , TRIM(wrf_err_message) )
184 WRITE(wrf_err_message,*)'2) use force_use_old_data=T in the time_control record of the namelist.input file'
185 CALL wrf_debug( 0 , TRIM(wrf_err_message) )
186 WRITE(wrf_err_message,*)'---- ERROR: The input file appears to be from a pre-v4 version of WRF initialization routines'
187 CALL wrf_error_fatal( wrf_err_message )
188 END IF
189 END IF
191 ! Verify feature consistency between model input and model nml settings
193 IF ( .NOT. dryrun ) THEN
195 IF ( switch .EQ. input_only ) THEN
196 CALL wrf_get_dom_ti_char ( fid , 'TITLE' , version_name, ierr )
198 IF ( INDEX(TRIM(version_name),' V4.') .NE. 0 ) THEN
199 CALL wrf_get_dom_ti_integer( fid , 'HYBRID_OPT', hybrid_opt, 1, icnt, ierr )
200 CALL wrf_get_dom_ti_integer( fid , 'USE_THETA_M', use_theta_m, 1, icnt, ierr )
202 IF ( hybrid_opt .NE. config_flags%hybrid_opt ) THEN
203 WRITE(wrf_err_message,*) '---- ERROR: Input file hybrid_opt = ',hybrid_opt
204 CALL wrf_debug ( 0, TRIM(wrf_err_message) )
205 WRITE(wrf_err_message,*) '---- ERROR: Namelist hybrid_opt = ',config_flags%hybrid_opt
206 CALL wrf_debug ( 0, TRIM(wrf_err_message) )
207 CALL wrf_debug ( 0, "---- ERROR: hybrid_opt values must be consistent" )
208 count_fatal_error = count_fatal_error + 1
209 END IF
211 IF ( use_theta_m .NE. config_flags%use_theta_m ) THEN
212 WRITE(wrf_err_message,*) '---- ERROR: Input file use_theta_m = ',use_theta_m
213 CALL wrf_debug ( 0, TRIM(wrf_err_message) )
214 WRITE(wrf_err_message,*) '---- ERROR: Namelist use_theta_m = ',config_flags%use_theta_m
215 CALL wrf_debug ( 0, TRIM(wrf_err_message) )
216 CALL wrf_debug ( 0, "---- ERROR: use_theta_m values must be consistent" )
217 count_fatal_error = count_fatal_error + 1
218 END IF
220 END IF
222 ELSE IF ( switch .EQ. auxinput1_only ) THEN
223 CALL wrf_get_dom_ti_char ( fid , 'TITLE' , version_name, ierr )
224 IF ( INDEX(TRIM(version_name),' V4.') .NE. 0 ) THEN
225 grid%v4_metgrid = .TRUE.
226 ELSE
227 grid%v4_metgrid = .FALSE.
228 END IF
229 END IF
230 END IF
232 ! INPUT ONLY (KK)
234 IF ( switch .EQ. restart_only ) THEN
236 ! recover the restart alarms from input if available
238 CALL wrf_get_dom_ti_integer( fid , 'MAX_WRF_ALARMS', max_wrf_alarms_compare, 1, icnt, ierr )
239 IF ( max_wrf_alarms_compare .NE. MAX_WRF_ALARMS ) THEN
240 WRITE(wrf_err_message,*)'MAX_WRF_ALARMS different in restart file (',max_wrf_alarms_compare,&
241 ') from in code (',MAX_WRF_ALARMS,'). Disregarding info in restart file.'
242 ELSE
243 curtime = domain_get_current_time( grid )
244 DO i = auxinput1_only, MAX_WRF_ALARMS
245 IF ( grid%alarms_created(i) .AND. .NOT. i .EQ. boundary_only ) THEN
246 write(alarmname,'("WRF_ALARM_ISRINGING_",i2.2)')i
247 CALL wrf_get_dom_ti_integer( fid, TRIM(alarmname), iring, 1, icnt, ierr )
249 write(alarmname,'("WRF_ALARM_SECS_TIL_NEXT_RING_",i2.2)')i
250 CALL wrf_get_dom_ti_integer( fid, TRIM(alarmname), seconds, 1, icnt, ierr )
251 IF ( ierr .EQ. 0 &
252 .AND. seconds .GE. 0 ) THEN ! disallow negative intervals; can happen with wrfbdy datasets
253 ! which keep time differently
255 ! Get and set interval so that we are sure to have both the
256 ! interval and first ring time set correctly
257 CALL WRFU_AlarmGet( grid%alarms(i), ringinterval=interval2 )
259 IF (config_flags%override_restart_timers) THEN
260 IF (i .EQ. restart_only) THEN
261 seconds = grid%restart_interval_d * 86400 + &
262 grid%restart_interval_h * 3600 + &
263 grid%restart_interval_m * 60 + &
264 grid%restart_interval * 60 + &
265 grid%restart_interval_s
266 ENDIF
267 ENDIF
269 CALL WRFU_TimeIntervalSet(interval,S=seconds)
270 ringTime = curtime + interval
271 CALL WRFU_AlarmSet( grid%alarms(i), RingInterval=interval2, RingTime=ringTime )
273 ENDIF
275 IF ( iring .EQ. 1 ) THEN
276 CALL WRFU_AlarmRingerOn( grid%alarms( i ) )
277 ELSE
278 CALL WRFU_AlarmRingerOff( grid%alarms( i ) )
279 ENDIF
280 ENDIF
281 ENDDO
282 ENDIF
285 !OUTPUT ONLY (KK)
287 IF ( switch .EQ. restart_only .AND. .NOT. config_flags%override_restart_timers ) THEN
289 ! recover the restart alarms from input if available
291 CALL wrf_get_dom_ti_integer( fid , 'MAX_WRF_ALARMS', max_wrf_alarms_compare, 1, icnt, ierr )
292 IF ( max_wrf_alarms_compare .NE. MAX_WRF_ALARMS ) THEN
293 WRITE(wrf_err_message,*)'MAX_WRF_ALARMS different in restart file (',max_wrf_alarms_compare,&
294 ') from in code (',MAX_WRF_ALARMS,'). Disregarding info in restart file.'
295 ELSE
296 curtime = domain_get_current_time( grid )
297 DO i = 1, auxinput1_only-1
298 IF ( grid%alarms_created(i) .AND. .NOT. i .EQ. boundary_only ) THEN
299 write(alarmname,'("WRF_ALARM_ISRINGING_",i2.2)')i
300 CALL wrf_get_dom_ti_integer( fid, TRIM(alarmname), iring, 1, icnt, ierr )
302 write(alarmname,'("WRF_ALARM_SECS_TIL_NEXT_RING_",i2.2)')i
303 CALL wrf_get_dom_ti_integer( fid, TRIM(alarmname), seconds, 1, icnt, ierr )
304 IF ( ierr .EQ. 0 &
305 .AND. seconds .GE. 0 ) THEN ! disallow negative intervals; can happen with wrfbdy datasets
306 ! which keep time differently
308 ! Get and set interval so that we are sure to have both the
309 ! interval and first ring time set correctly
310 CALL WRFU_AlarmGet( grid%alarms(i), ringinterval=interval2 )
312 IF (config_flags%override_restart_timers) THEN
313 IF (i .EQ. history_only) THEN
314 seconds = grid%history_interval_d * 86400 + &
315 grid%history_interval_h * 3600 + &
316 grid%history_interval_m * 60 + &
317 grid%history_interval * 60 + &
318 grid%history_interval_s
319 ENDIF
320 ENDIF
322 CALL WRFU_TimeIntervalSet(interval,S=seconds)
323 ringTime = curtime + interval
324 CALL WRFU_AlarmSet( grid%alarms(i), RingInterval=interval, RingTime=ringTime )
326 ENDIF
328 IF ( iring .EQ. 1 ) THEN
329 CALL WRFU_AlarmRingerOn( grid%alarms( i ) )
330 ELSE
331 CALL WRFU_AlarmRingerOff( grid%alarms( i ) )
332 ENDIF
333 ENDIF
334 ENDDO
335 ENDIF
337 ENDIF
339 CALL wrf_get_dom_ti_char ( fid , 'SIMULATION_START_DATE' , simulation_start_date , ierr )
340 CALL nl_get_reset_simulation_start ( 1, reset_simulation_start )
342 IF ( ( ierr .EQ. 0 ) .AND. ( .NOT. reset_simulation_start ) ) THEN
343 ! Overwrite simulation start date with metadata.
344 #ifdef PLANET
345 READ ( simulation_start_date , fmt = '(I4,1x,I5,1x,I2,1x,I2,1x,I2)' ) &
346 simulation_start_year, &
347 simulation_start_day, simulation_start_hour, &
348 simulation_start_minute, simulation_start_second
349 simulation_start_month = 0
350 #else
351 READ ( simulation_start_date , fmt = '(I4,1x,I2,1x,I2,1x,I2,1x,I2,1x,I2)' ) &
352 simulation_start_year, simulation_start_month, &
353 simulation_start_day, simulation_start_hour, &
354 simulation_start_minute, simulation_start_second
355 #endif
356 CALL nl_set_simulation_start_year ( 1 , simulation_start_year )
357 CALL nl_set_simulation_start_month ( 1 , simulation_start_month )
358 CALL nl_set_simulation_start_day ( 1 , simulation_start_day )
359 CALL nl_set_simulation_start_hour ( 1 , simulation_start_hour )
360 CALL nl_set_simulation_start_minute ( 1 , simulation_start_minute )
361 CALL nl_set_simulation_start_second ( 1 , simulation_start_second )
362 IF ( switch .EQ. input_only ) THEN
363 WRITE(wrf_err_message,*) ' input_wrf, input_only: SIMULATION_START_DATE = ', &
364 simulation_start_date(1:19)
365 CALL wrf_debug ( 300 , TRIM(wrf_err_message ) )
366 ELSE IF ( switch .EQ. restart_only ) THEN
367 WRITE(wrf_err_message,*) ' input_wrf, restart_only: SIMULATION_START_DATE = ', &
368 simulation_start_date(1:19)
369 CALL wrf_debug ( 300 , TRIM(wrf_err_message ) )
370 ENDIF
371 ELSE
372 CALL nl_get_start_year ( 1 , simulation_start_year )
373 CALL nl_get_start_month ( 1 , simulation_start_month )
374 CALL nl_get_start_day ( 1 , simulation_start_day )
375 CALL nl_get_start_hour ( 1 , simulation_start_hour )
376 CALL nl_get_start_minute ( 1 , simulation_start_minute )
377 CALL nl_get_start_second ( 1 , simulation_start_second )
378 CALL nl_set_simulation_start_year ( 1 , simulation_start_year )
379 CALL nl_set_simulation_start_month ( 1 , simulation_start_month )
380 CALL nl_set_simulation_start_day ( 1 , simulation_start_day )
381 CALL nl_set_simulation_start_hour ( 1 , simulation_start_hour )
382 CALL nl_set_simulation_start_minute ( 1 , simulation_start_minute )
383 CALL nl_set_simulation_start_second ( 1 , simulation_start_second )
384 IF ( reset_simulation_start ) THEN
385 CALL wrf_message('input_wrf: forcing SIMULATION_START_DATE = head_grid start time')
386 CALL wrf_message(' due to namelist variable reset_simulation_start')
387 ELSE
388 CALL wrf_message('input_wrf: SIMULATION_START_DATE not available in input')
389 CALL wrf_message('will use head_grid start time from namelist')
390 ENDIF
391 ENDIF
392 ! Initialize derived time quantity in grid%xtime.
393 ! Note that this call is also made in setup_timekeeping().
394 ! Ugh, what a hack. Simplify all this later...
395 CALL domain_clock_get( grid, minutesSinceSimulationStart=grid%xtime )
396 ! Note that it is NOT necessary to reset grid%julian here.
397 WRITE(wrf_err_message,*) 'input_wrf: set xtime to ',grid%xtime
398 CALL wrf_debug ( 100, TRIM(wrf_err_message) )
399 ELSE IF ( switch .EQ. auxinput1_only ) then
400 CALL wrf_get_dom_ti_char ( fid , 'SIMULATION_START_DATE' , first_date_input , ierr )
401 WRITE(wrf_err_message,*)'metgrid input_wrf.F first_date_input = ',first_date_input
402 CALL wrf_message(wrf_err_message)
403 CALL nl_get_start_year ( 1 , first_date_start_year )
404 CALL nl_get_start_month ( 1 , first_date_start_month )
405 CALL nl_get_start_day ( 1 , first_date_start_day )
406 CALL nl_get_start_hour ( 1 , first_date_start_hour )
407 CALL nl_get_start_minute ( 1 , first_date_start_minute )
408 CALL nl_get_start_second ( 1 , first_date_start_second )
409 WRITE ( first_date_nml, fmt = '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) &
410 first_date_start_year, first_date_start_month, &
411 first_date_start_day, first_date_start_hour, &
412 first_date_start_minute, first_date_start_second
413 WRITE (wrf_err_message,*) 'metgrid input_wrf.F first_date_nml = ',first_date_nml
414 CALL wrf_message( TRIM(wrf_err_message ) )
415 ENDIF
417 ! Test to make sure that the input data is the right size. Do this for input from real/ideal into
418 ! WRF, and from the standard initialization into real.
420 IF ( ( switch .EQ. input_only ) .OR. &
421 ( switch .EQ. auxinput1_only ) ) THEN
422 ierr = 0
423 CALL wrf_get_dom_ti_integer ( fid , 'WEST-EAST_GRID_DIMENSION' , ide_compare , 1 , icnt , ierr3 )
424 ierr = max( ierr, ierr3 )
425 CALL wrf_get_dom_ti_integer ( fid , 'SOUTH-NORTH_GRID_DIMENSION' , jde_compare , 1 , icnt , ierr3 )
426 ierr = max( ierr, ierr3 )
427 CALL wrf_get_dom_ti_integer ( fid , 'BOTTOM-TOP_GRID_DIMENSION' , kde_compare , 1 , icnt , ierr3 )
428 ierr = max( ierr, ierr3 )
429 IF ( ierr3 .NE. 0 ) THEN
430 CALL wrf_debug ( 0, '---- ERROR: wrf_get_dom_ti_integer getting dimension information from dataset' )
431 count_fatal_error = count_fatal_error + 1
432 END IF
434 #if (EM_CORE == 1)
436 IF ( switch .EQ. input_only ) then
437 CALL wrf_get_dom_ti_char ( fid , 'SIMULATION_START_DATE' , simulation_start_date , ierr )
438 END IF
440 ! Test to make sure that the grid distances are the right size.
442 CALL wrf_get_dom_ti_real ( fid , 'DX' , dx_compare , 1 , icnt , ierr )
443 CALL wrf_get_dom_ti_real ( fid , 'DY' , dy_compare , 1 , icnt , ierr )
445 IF ( ( ABS ( dx_compare - config_flags%dx ) .GT. 1.E-5 * dx_compare ) .OR. &
446 ( ABS ( dy_compare - config_flags%dy ) .GT. 1.E-5 * dy_compare ) ) THEN
447 IF ( ( config_flags%polar ) .AND. ( config_flags%grid_id .EQ. 1 ) ) THEN
448 WRITE(wrf_err_message,*)'input_wrf: DX and DY from input file expected to be wrong'
449 CALL wrf_debug ( 1 , wrf_err_message )
450 ELSE
451 WRITE(wrf_err_message,*)'dx and dy from file ',dx_compare,dy_compare
452 CALL wrf_message(wrf_err_message)
453 WRITE(wrf_err_message,*)'dx and dy from namelist ',config_flags%dx,config_flags%dy
454 CALL wrf_message(wrf_err_message)
455 CALL wrf_debug ( 0, '---- ERROR: DX and DY do not match comparing namelist to the input file' )
456 count_fatal_error = count_fatal_error + 1
457 END IF
458 END IF
459 #endif
460 END IF
462 #if (EM_CORE == 1)
463 IF ( ( switch .EQ. input_only ) .OR. ( switch .EQ. auxinput2_only ) .OR. ( switch .EQ. auxinput1_only ) ) THEN
464 ierr = 0
465 ierr3 = 0
466 IF ( ( ( switch .EQ. input_only ) .AND. ( grid%id .GE. 2 ) ) .OR. ( switch .EQ. auxinput2_only ) ) THEN
467 CALL wrf_get_dom_ti_integer ( fid , 'I_PARENT_START' , itmp , 1 , icnt , ierr3 )
468 ELSE IF ( ( switch .EQ. auxinput1_only ) .AND. ( grid%id .GE. 2 ) ) THEN
469 CALL wrf_get_dom_ti_integer ( fid , 'i_parent_start' , itmp , 1 , icnt , ierr3 )
470 ELSE IF ( ( ( switch .EQ. auxinput1_only ) .OR. ( switch .EQ. input_only ) ) .AND. ( grid%id .EQ. 1 ) ) THEN
471 itmp = config_flags%i_parent_start
472 ierr3 = 0
473 END IF
474 ierr = max( ierr, ierr3 )
475 IF ( itmp .NE. config_flags%i_parent_start ) THEN
476 ierr = 1
477 WRITE(wrf_err_message,*)'i_parent_start from namelist.input file = ',config_flags%i_parent_start
478 CALL wrf_message(wrf_err_message)
479 WRITE(wrf_err_message,*)'i_parent_start from gridded input file = ',itmp
480 CALL wrf_message(wrf_err_message)
481 END IF
482 IF ( ( ( switch .EQ. input_only ) .AND. ( grid%id .GE. 2 ) ) .OR. ( switch .EQ. auxinput2_only ) ) THEN
483 CALL wrf_get_dom_ti_integer ( fid , 'J_PARENT_START' , itmp , 1 , icnt , ierr3 )
484 ELSE IF ( ( switch .EQ. auxinput1_only ) .AND. ( grid%id .GE. 2 ) ) THEN
485 CALL wrf_get_dom_ti_integer ( fid , 'j_parent_start' , itmp , 1 , icnt , ierr3 )
486 ELSE IF ( ( ( switch .EQ. auxinput1_only ) .OR. ( switch .EQ. input_only ) ) .AND. ( grid%id .EQ. 1 ) ) THEN
487 itmp = config_flags%j_parent_start
488 ierr3 = 0
489 END IF
490 ierr = max( ierr, ierr3 )
491 IF ( itmp .NE. config_flags%j_parent_start ) THEN
492 ierr = 1
493 WRITE(wrf_err_message,*)'j_parent_start from namelist.input file = ',config_flags%j_parent_start
494 CALL wrf_message(wrf_err_message)
495 WRITE(wrf_err_message,*)'j_parent_start from gridded input file = ',itmp
496 CALL wrf_message(wrf_err_message)
497 END IF
498 IF ( ierr .NE. 0 ) THEN
499 CALL wrf_debug ( 0, '---- ERROR: Nest start locations do not match: namelist.input vs gridded input file' )
500 count_fatal_error = count_fatal_error + 1
501 END IF
502 END IF
503 #endif
505 ! do the check later (see check_if_dryrun below)
507 ! We do not want the CEN_LAT LON values from the boundary file. For 1-way nests
508 ! with ndown, this ends up being the data from the previous coarse domain.
510 IF ( switch .NE. boundary_only ) THEN
511 CALL wrf_get_dom_ti_real ( fid , 'CEN_LAT' , config_flags%cen_lat , 1 , icnt , ierr )
512 WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for CEN_LAT returns ',config_flags%cen_lat
513 CALL wrf_debug ( 300 , wrf_err_message )
514 CALL nl_set_cen_lat ( grid%id , config_flags%cen_lat )
516 CALL wrf_get_dom_ti_real ( fid , 'CEN_LON' , config_flags%cen_lon , 1 , icnt , ierr )
517 WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for CEN_LON returns ',config_flags%cen_lon
518 CALL wrf_debug ( 300 , wrf_err_message )
519 CALL nl_set_cen_lon ( grid%id , config_flags%cen_lon )
520 ELSE
521 CALL wrf_get_dom_ti_real ( fid , 'CEN_LAT' , dum , 1 , icnt , ierr )
522 WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for CEN_LAT returns ',dum
523 CALL wrf_debug ( 300 , wrf_err_message )
525 CALL wrf_get_dom_ti_real ( fid , 'CEN_LON' , dum , 1 , icnt , ierr )
526 WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for CEN_LON returns ',dum
527 CALL wrf_debug ( 300 , wrf_err_message )
528 END IF
530 CALL wrf_get_dom_ti_real ( fid , 'TRUELAT1' , config_flags%truelat1 , 1 , icnt , ierr )
531 WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for TRUELAT1 returns ',config_flags%truelat1
532 CALL wrf_debug ( 300 , wrf_err_message )
533 CALL nl_set_truelat1 ( grid%id , config_flags%truelat1 )
535 CALL wrf_get_dom_ti_real ( fid , 'TRUELAT2' , config_flags%truelat2 , 1 , icnt , ierr )
536 WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for TRUELAT2 returns ',config_flags%truelat2
537 CALL wrf_debug ( 300 , wrf_err_message )
538 CALL nl_set_truelat2 ( grid%id , config_flags%truelat2 )
540 CALL wrf_get_dom_ti_real ( fid , 'MOAD_CEN_LAT' , config_flags%moad_cen_lat , 1 , icnt , ierr )
541 WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for MOAD_CEN_LAT returns ',config_flags%moad_cen_lat
542 CALL wrf_debug ( 300 , wrf_err_message )
543 CALL nl_set_moad_cen_lat ( grid%id , config_flags%moad_cen_lat )
545 CALL wrf_get_dom_ti_real ( fid , 'STAND_LON' , config_flags%stand_lon , 1 , icnt , ierr )
546 WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for STAND_LON returns ',config_flags%stand_lon
547 CALL wrf_debug ( 300 , wrf_err_message )
548 CALL nl_set_stand_lon ( grid%id , config_flags%stand_lon )
550 CALL wrf_get_dom_ti_real ( fid , 'POLE_LAT' , config_flags%pole_lat , 1 , icnt , ierr )
551 WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for POLE_LAT returns ',config_flags%pole_lat
552 CALL wrf_debug ( 300 , wrf_err_message )
553 CALL nl_set_pole_lat ( grid%id , config_flags%pole_lat )
555 CALL wrf_get_dom_ti_real ( fid , 'POLE_LON' , config_flags%pole_lon , 1 , icnt , ierr )
556 WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for POLE_LON returns ',config_flags%pole_lon
557 CALL wrf_debug ( 300 , wrf_err_message )
558 CALL nl_set_pole_lon ( grid%id , config_flags%pole_lon )
560 ! program_name is defined in module_domain and set in the main program for whatever application
561 ! is using subroutine input_wrf (that is, the subroutine you are looking at here). Data files
562 ! written by SI have P_TOP as a metadata item; the real program and wrf model have it as a
563 ! state variable. This test is to supress non-fatal but confusing messages from the model complaining
564 ! that P_TOP cannot be read from the metadata for this dataset. JM 20040905
566 IF ( program_name(1:7) .EQ. "REAL_EM" ) THEN
567 CALL wrf_get_dom_ti_real ( fid , 'P_TOP' , grid%p_top , 1 , icnt , ierr )
568 WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for P_TOP returns ',grid%p_top
569 CALL wrf_debug ( 300 , wrf_err_message )
570 ENDIF
572 IF ( switch .NE. boundary_only ) THEN
573 CALL wrf_get_dom_ti_real ( fid , 'GMT' , config_flags%gmt , 1 , icnt , ierr )
574 WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for GMT returns ',config_flags%gmt
575 CALL wrf_debug ( 300 , wrf_err_message )
576 CALL nl_set_gmt ( grid%id , config_flags%gmt )
578 CALL wrf_get_dom_ti_integer ( fid , 'JULYR' , config_flags%julyr , 1 , icnt , ierr )
579 WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for JULYR returns ',config_flags%julyr
580 CALL wrf_debug ( 300 , wrf_err_message )
581 CALL nl_set_julyr ( grid%id , config_flags%julyr )
583 CALL wrf_get_dom_ti_integer ( fid , 'JULDAY' , config_flags%julday , 1 , icnt , ierr )
584 WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for JULDAY returns ',config_flags%julday
585 CALL wrf_debug ( 300 , wrf_err_message )
586 CALL nl_set_julday ( grid%id , config_flags%julday )
587 ENDIF
589 CALL wrf_get_dom_ti_integer ( fid , 'MAP_PROJ' , config_flags%map_proj , 1 , icnt , ierr )
590 WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for MAP_PROJ returns ',config_flags%map_proj
591 CALL wrf_debug ( 300 , wrf_err_message )
592 CALL nl_set_map_proj ( grid%id , config_flags%map_proj )
593 grid%map_proj = config_flags%map_proj
595 mminlu = " "
596 CALL wrf_get_dom_ti_char ( fid , 'MMINLU', mminlu , ierr )
597 IF ( ierr .NE. 0 ) mminlu = " "
598 #if ( ( EM_CORE == 1 ) && ( DA_CORE != 1 ) )
599 IF ( ( ( switch .EQ. input_only ) .OR. ( switch .EQ. restart_only ) ) .AND. &
600 ( ( config_flags%io_form_input .EQ. 2 ) .OR. &
601 ( config_flags%io_form_input .EQ. 11 ) ) ) THEN
602 CALL wrf_get_dom_ti_char ( fid , 'SIMULATION_INITIALIZATION_TYPE', sim_type , icnt )
603 IF ( TRIM(sim_type) .NE. "IDEALIZED DATA" ) THEN
604 IF ( ierr .NE. 0 ) THEN
605 WRITE(wrf_err_message,*)'MMINLU error on input'
606 mminlu = " "
607 CALL wrf_debug ( 0 , wrf_err_message )
608 END IF
609 END IF
610 ELSE IF ( ( switch .EQ. input_only ) .OR. ( switch .EQ. restart_only ) ) THEN
611 IF ( ierr .NE. 0 ) THEN
612 WRITE(wrf_err_message,*)'MMINLU error on input'
613 mminlu = " "
614 CALL wrf_debug ( 0 , wrf_err_message )
615 END IF
616 END IF
617 #endif
618 IF ( ierr .EQ. 0 ) THEN
619 IF ( ( ( mminlu(1:1) .GE. "A" ) .AND. ( mminlu(1:1) .LE. "Z" ) ) .OR. &
620 ( ( mminlu(1:1) .GE. "a" ) .AND. ( mminlu(1:1) .LE. "z" ) ) .OR. &
621 ( ( mminlu(1:1) .GE. "0" ) .AND. ( mminlu(1:1) .LE. "9" ) ) ) THEN
622 ! no-op, the mminlu field is probably OK
623 ELSE IF ( mminlu(1:1) .EQ. " " ) THEN
624 mminlu = " "
625 ELSE
626 mminlu = " "
627 END IF
628 END IF
629 call wrf_debug( 1 , "mminlu = '" // TRIM(mminlu) // "'")
630 if (index(mminlu, char(0)) > 0) mminlu(index(mminlu, char(0)):) = " "
631 WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_char for MMINLU returns ' // TRIM(mminlu)
632 CALL wrf_debug ( 300 , wrf_err_message )
633 CALL nl_set_mminlu ( grid%id, mminlu )
635 ! Test to make sure that the number of land categories is set correctly
636 ! The default is set to 24 somewhere, from the number of categories
637 ! in the traditional USGS dataset
639 IF ( ( switch .EQ. input_only ) .OR. &
640 ( switch .EQ. auxinput1_only ) .OR. &
641 ( switch .EQ. auxinput2_only ) ) THEN
642 call wrf_get_dom_ti_integer(fid, "NUM_LAND_CAT", num_land_cat_compare, 1, icnt, ierr)
643 if ( (ierr .NE. 0) .OR. ( num_land_cat_compare .LT. 1 ) .OR. ( num_land_cat_compare .GT. 1000 ) ) then
644 IF (mminlu == 'MODIFIED_IGBP_MODIS_NOAH') THEN
645 call wrf_debug( 1 , "Must be old WPS data, assuming 20 levels for NUM_LAND_CAT")
646 num_land_cat_compare = 20
647 ELSE
648 call wrf_debug( 1 , "Must be old WPS data, assuming 24 levels for NUM_LAND_CAT")
649 num_land_cat_compare = 24
650 END IF
651 endif
652 if ( config_flags%num_land_cat /= num_land_cat_compare ) then
653 call wrf_message("----------------- ERROR -------------------")
654 WRITE(wrf_err_message,'("namelist : NUM_LAND_CAT = ",I10)') config_flags%num_land_cat
655 call wrf_message(wrf_err_message)
656 WRITE(wrf_err_message,'("input files : NUM_LAND_CAT = ",I10, " (from geogrid selections).")') num_land_cat_compare
657 call wrf_message(wrf_err_message)
658 CALL wrf_debug ( 0, '---- ERROR: Mismatch between namelist and wrf input files for dimension NUM_LAND_CAT')
659 count_fatal_error = count_fatal_error + 1
660 endif
661 ENDIF
663 ! Test here to check that config_flags%num_metgrid_soil_levels in namelist
664 ! is equal to what is in the global attributes of the met_em files. Note that
665 ! if this is not the first time period, we don't really care about soil data.
667 IF ( ( switch .EQ. auxinput1_only ) .AND. &
668 ( first_date_nml .EQ. first_date_input ) ) THEN
669 CALL wrf_get_dom_ti_integer ( fid, 'NUM_METGRID_SOIL_LEVELS', itmp, 1, icnt, ierr )
671 IF ( ierr .EQ. 0 ) THEN
673 #if (EM_CORE == 1)
674 IF ( itmp .EQ. 1 ) THEN
675 CALL wrf_debug ( 0, "---- ERROR: NUM_METGRID_SOIL_LEVELS must be greater than 1")
676 count_fatal_error = count_fatal_error + 1
677 END IF
678 #endif
679 WRITE(wrf_err_message,*)'input_wrf: global attribute NUM_METGRID_SOIL_LEVELS returns ', itmp
680 CALL wrf_debug ( 300 , wrf_err_message )
681 IF ( config_flags%num_metgrid_soil_levels /= itmp ) THEN
682 call wrf_message("----------------- ERROR -------------------")
683 WRITE(wrf_err_message,'("namelist : num_metgrid_soil_levels = ",I10)') config_flags%num_metgrid_soil_levels
684 call wrf_message(wrf_err_message)
685 #if (EM_CORE == 1)
686 WRITE(wrf_err_message,'("input files : NUM_METGRID_SOIL_LEVELS = ",I10, " (from met_em files).")') itmp
687 #else
688 WRITE(wrf_err_message,'("input files : NUM_METGRID_SOIL_LEVELS = ",I10, " (from met_nmm files).")') itmp
689 #endif
690 call wrf_message(wrf_err_message)
691 CALL wrf_debug ( 0, "---- ERROR: Mismatch between namelist and global attribute NUM_METGRID_SOIL_LEVELS")
692 count_fatal_error = count_fatal_error + 1
693 END IF
694 END IF
695 END IF
697 #if 0
698 #if ( WRF_CHEM == 1 )
699 ! Dust erosion static data.
701 CALL wrf_get_dom_ti_integer ( fid, 'EROSION_DIM', itmp, 1, icnt, ierr )
703 IF ( ierr .EQ. 0 ) THEN
704 WRITE(wrf_err_message,*)'input_wrf: global attribute EROSION_DIM returns ', itmp
705 CALL wrf_debug ( 300 , wrf_err_message )
706 IF ( config_flags%erosion_dim /= itmp ) THEN
707 call wrf_message("----------------- ERROR -------------------")
708 WRITE(wrf_err_message,'("namelist : erosion_dim = ",I10)') config_flags%erosion_dim
709 call wrf_message(wrf_err_message)
710 WRITE(wrf_err_message,'("input files : EROSION_DIM = ",I10, " (from met_em files).")') itmp
711 call wrf_message(wrf_err_message)
712 CALL wrf_debug ( 0, "---- ERROR: Mismatch between namelist and global attribute EROSION_DIM")
713 count_fatal_error = count_fatal_error + 1
714 END IF
715 END IF
716 #endif
717 #endif
719 #if ( DA_CORE != 1 )
720 ! Test here to check that config_flags%sf_surface_physics in namelist
721 ! is equal to what is in the global attributes of the wrfinput files
723 IF ( config_flags%sf_surface_physics /= 0 ) THEN
724 IF ( switch .EQ. input_only ) THEN
725 CALL wrf_get_dom_ti_integer ( fid, 'SF_SURFACE_PHYSICS', itmp, 1, icnt, ierr )
726 IF ( ierr .EQ. 0 ) THEN
727 WRITE(wrf_err_message,*)'input_wrf: global attribute SF_SURFACE_PHYSICS returns ', itmp
728 CALL wrf_debug ( 300 , wrf_err_message )
729 IF ( config_flags%sf_surface_physics /= itmp ) THEN
730 IF ( ( config_flags%sf_surface_physics == LSMSCHEME ) .and. ( itmp == NOAHMPSCHEME ) ) then
731 ! All is well. Noah-MP and Noah have compatible wrfinput files.
732 ELSE IF ( ( config_flags%sf_surface_physics == NOAHMPSCHEME ) .and. ( itmp == LSMSCHEME ) ) then
733 ! All is well. Noah-MP and Noah have compatible wrfinput files.
734 ELSE IF ( ( config_flags%sf_surface_physics == CTSMSCHEME ) ) then
735 ! All is well. CTSM doesn't care about the wrfinput file.
736 ELSE
737 call wrf_message("----------------- ERROR -------------------")
738 WRITE(wrf_err_message,'("namelist : sf_surface_physics = ",I10)') config_flags%sf_surface_physics
739 call wrf_message(wrf_err_message)
740 WRITE(wrf_err_message,'("input files : SF_SURFACE_PHYSICS = ",I10, " (from wrfinput files).")') itmp
741 call wrf_message(wrf_err_message)
742 CALL wrf_debug ( 0, "---- ERROR: Mismatch between namelist and global attribute SF_SURFACE_PHYSICS")
743 count_fatal_error = count_fatal_error + 1
744 END IF
745 END IF
746 END IF
747 END IF
748 END IF
751 ! Test here to check that config_flags%gwd_opt in namelist
752 ! is equal to what is in the global attributes of the wrfinput files
754 IF ( config_flags%gwd_opt /= 0 ) THEN
755 IF ( switch .EQ. input_only ) THEN
756 CALL wrf_get_dom_ti_integer ( fid, 'GWD_OPT', itmp, 1, icnt, ierr )
757 IF ( ierr .EQ. 0 ) THEN
758 WRITE(wrf_err_message,*)'input_wrf: global attribute GWD_OPT returns ', itmp
759 CALL wrf_debug ( 300 , wrf_err_message )
760 IF ( config_flags%gwd_opt /= itmp ) THEN
761 call wrf_message("----------------- ERROR -------------------")
762 WRITE(wrf_err_message,'("namelist : gwd_opt = ",I10)') config_flags%gwd_opt
763 call wrf_message(wrf_err_message)
764 WRITE(wrf_err_message,'("input files : GWD_OPT = ",I10, " (from wrfinput files).")') itmp
765 call wrf_message(wrf_err_message)
766 call wrf_debug ( 0, "---- ERROR: Mismatch between namelist and global attribute GWD_OPT")
767 count_fatal_error = count_fatal_error + 1
768 END IF
769 END IF
770 END IF
771 END IF
772 #endif
774 #if ( ( EM_CORE == 1 ) && ( DA_CORE != 1 ) )
775 ! Test here to check that config_flags%sf_ocean_physics in namelist
776 ! is equal to what is in the global attributes of the wrfinput files
778 IF ( config_flags%sf_ocean_physics /= 0 ) THEN
779 IF ( switch .EQ. input_only ) THEN
780 CALL wrf_get_dom_ti_integer ( fid, 'SF_OCEAN_PHYSICS', itmp, 1, icnt, ierr )
781 IF ( ierr .EQ. 0 ) THEN
782 WRITE(wrf_err_message,*)'input_wrf: global attribute SF_OCEAN_PHYSICS returns ', itmp
783 CALL wrf_debug ( 300 , wrf_err_message )
784 IF ( config_flags%sf_ocean_physics /= itmp ) THEN
785 call wrf_message("----------------- ERROR -------------------")
786 WRITE(wrf_err_message,'("namelist : sf_ocean_physics = ",I10)') config_flags%sf_ocean_physics
787 call wrf_message(wrf_err_message)
788 WRITE(wrf_err_message,'("input files : SF_OCEAN_PHYSICS = ",I10, " (from wrfinput files).")') itmp
789 call wrf_message(wrf_err_message)
790 call wrf_debug ( 0, "---- ERROR: Mismatch between namelist and global attribute SF_OCEAN_PHYSICS")
791 count_fatal_error = count_fatal_error + 1
792 END IF
793 END IF
794 END IF
795 END IF
796 #endif
798 #if ( DA_CORE != 1 )
799 ! Test here to check that config_flags%sf_urban_physics in namelist
800 ! is equal to the value listed the global attributes of the wrfinput files.
801 ! We only perform this check if the WRF model has sf_urban_physics turned on.
802 ! If the WRF model runs with nml sf_urban_physics==0, then any setting of the
803 ! sf_urban_physics in the metadata is acceptable, so not test is required.
805 IF ( config_flags%sf_urban_physics /= 0 ) THEN
806 IF ( switch .EQ. input_only ) THEN
807 CALL wrf_get_dom_ti_integer ( fid, 'SF_URBAN_PHYSICS', itmp, 1, icnt, ierr )
808 IF ( ierr .EQ. 0 ) THEN
809 WRITE(wrf_err_message,*)'input_wrf: global attribute SF_URBAN_PHYSICS returns ', itmp
810 CALL wrf_debug ( 300 , wrf_err_message )
811 IF ( config_flags%sf_urban_physics /= itmp ) THEN
812 call wrf_message("----------------- ERROR -------------------")
813 WRITE(wrf_err_message,'("namelist : sf_urban_physics = ",I10)') config_flags%sf_urban_physics
814 call wrf_message(wrf_err_message)
815 WRITE(wrf_err_message,'("input files : SF_URBAN_PHYSICS = ",I10, " (from wrfinput files).")') itmp
816 call wrf_message(wrf_err_message)
817 call wrf_debug ( 0, "---- ERROR: Mismatch between namelist and global attribute SF_URBAN_PHYSICS")
818 count_fatal_error = count_fatal_error + 1
819 END IF
820 END IF
821 END IF
822 END IF
823 #endif
825 CALL wrf_get_dom_ti_integer ( fid , 'ISWATER' , config_flags%iswater , 1 , icnt , ierr )
826 WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for ISWATER returns ',config_flags%iswater
827 CALL wrf_debug ( 300 , wrf_err_message )
828 IF ( ierr .NE. 0 ) THEN
829 IF (mminlu == 'UMD') THEN
830 config_flags%iswater = 14
831 ELSE IF (mminlu == 'MODIFIED_IGBP_MODIS_NOAH') THEN
832 config_flags%iswater = 17
833 ELSE
834 config_flags%iswater = 16
835 ENDIF
836 ENDIF
837 CALL nl_set_iswater ( grid%id , config_flags%iswater )
838 grid%iswater = config_flags%iswater
840 CALL wrf_get_dom_ti_integer ( fid , 'ISLAKE' , config_flags%islake , 1 , icnt , ierr )
841 WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for ISLAKE returns ',config_flags%islake
842 CALL wrf_debug ( 300 , wrf_err_message )
843 IF ( ierr .NE. 0 ) THEN
844 config_flags%islake = -1
845 ENDIF
846 CALL nl_set_islake ( grid%id , config_flags%islake )
847 grid%islake = config_flags%islake
849 CALL wrf_get_dom_ti_integer ( fid , 'ISICE' , config_flags%isice , 1 , icnt , ierr )
850 WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for ISICE returns ',config_flags%isice
851 CALL wrf_debug ( 300 , wrf_err_message )
852 IF ( ierr .NE. 0 ) THEN
853 IF (mminlu == 'UMD') THEN
854 config_flags%isice = 14
855 ELSE IF (mminlu == 'MODIFIED_IGBP_MODIS_NOAH') THEN
856 config_flags%isice = 15
857 ELSE
858 config_flags%isice = 24
859 ENDIF
860 ENDIF
861 CALL nl_set_isice ( grid%id , config_flags%isice )
862 grid%isice = config_flags%isice
864 CALL wrf_get_dom_ti_integer ( fid , 'ISURBAN' , config_flags%isurban , 1 , icnt , ierr )
865 WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for ISURBAN returns ',config_flags%isurban
866 CALL wrf_debug ( 300 , wrf_err_message )
867 IF ( ierr .NE. 0 ) THEN
868 IF (mminlu == 'UMD') THEN
869 config_flags%isurban = 13
870 ELSE IF (mminlu == 'MODIFIED_IGBP_MODIS_NOAH') THEN
871 config_flags%isurban = 13
872 ELSE
873 config_flags%isurban = 1
874 ENDIF
875 ENDIF
876 CALL nl_set_isurban ( grid%id , config_flags%isurban )
877 grid%isurban = config_flags%isurban
879 CALL wrf_get_dom_ti_integer ( fid , 'ISOILWATER' , config_flags%isoilwater , 1 , icnt , ierr )
880 WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for ISOILWATER returns ',config_flags%isoilwater
881 CALL wrf_debug ( 300 , wrf_err_message )
882 IF ( ierr .NE. 0 ) THEN
883 config_flags%isoilwater = 14
884 ENDIF
885 CALL nl_set_isoilwater ( grid%id , config_flags%isoilwater )
886 grid%isoilwater = config_flags%isoilwater
888 #ifdef MOVE_NESTS
889 ! Added these fields for restarting of moving nests, JM
890 ! DANGER and TODO
891 ! It is very important that these be set correctly if they are set at all in here.
892 ! Garbage values will produce unpredictable results, possibly segfaults, in the nesting
893 ! code. Need some integrity checking here or elsewhere in the code to at least check to
894 ! make sure that the istart and jstart values make sense with respect to the nest dimensions
895 ! and the position in the parent domain.
896 CALL wrf_get_dom_ti_integer ( fid , 'I_PARENT_START' , itmp , 1 , icnt, ierr )
897 IF ( ierr .EQ. 0 .AND. switch .EQ. restart_only ) THEN
898 config_flags%i_parent_start = itmp
899 CALL nl_set_i_parent_start ( grid%id , config_flags%i_parent_start )
900 ENDIF
901 CALL wrf_get_dom_ti_integer ( fid , 'J_PARENT_START' , itmp , 1 , icnt, ierr )
902 IF ( ierr .EQ. 0 .AND. switch .EQ. restart_only ) THEN
903 config_flags%j_parent_start = itmp
904 CALL nl_set_j_parent_start ( grid%id , config_flags%j_parent_start )
905 ENDIF
906 #endif
908 #if (EM_CORE == 1)
910 !KLUDGE - is there a more elegant way to determine "old si" input
911 IF ( ( switch .EQ. input_only ) .OR. &
912 ( ( switch .EQ. auxinput1_only ) .AND. &
913 ( config_flags%auxinput1_inname(1:8) .EQ. 'wrf_real' ) ) ) THEN
915 ! Test to make sure that the input data is the right size: real into WRF.
917 IF ( ide .NE. ide_compare ) THEN
918 WRITE(wrf_err_message,*)'input_wrf.F: SIZE MISMATCH: namelist e_we = ',ide
919 CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
920 WRITE(wrf_err_message,*)'input_wrf.F: SIZE MISMATCH: input file WEST-EAST_GRID_DIMENSION = ',ide_compare
921 CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
922 CALL wrf_debug ( 0, "---- ERROR: Mismatch between namelist and input file dimensions" )
923 count_fatal_error = count_fatal_error + 1
924 ENDIF
925 IF ( jde .NE. jde_compare ) THEN
926 WRITE(wrf_err_message,*)'input_wrf.F: SIZE MISMATCH: namelist e_sn = ',jde
927 CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
928 WRITE(wrf_err_message,*)'input_wrf.F: SIZE MISMATCH: input file SOUTH-NORTH_GRID_DIMENSION = ',jde_compare
929 CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
930 CALL wrf_debug ( 0, "---- ERROR: Mismatch between namelist and input file dimensions" )
931 count_fatal_error = count_fatal_error + 1
932 ENDIF
933 IF ( kde .NE. kde_compare ) THEN
934 WRITE(wrf_err_message,*)'input_wrf.F: SIZE MISMATCH: namelist e_vert = ',kde
935 CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
936 WRITE(wrf_err_message,*)'input_wrf.F: SIZE MISMATCH: input file BOTTOM-TOP_GRID_DIMENSION = ',kde_compare
937 CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
938 CALL wrf_debug ( 0, "---- ERROR: Mismatch between namelist and input file dimensions" )
939 count_fatal_error = count_fatal_error + 1
940 ENDIF
942 ELSE IF ( switch .EQ. auxinput1_only ) THEN
944 ! Test to make sure that the input data is the right size: metgrid into real.
946 IF ( ide .NE. ide_compare ) THEN
947 WRITE(wrf_err_message,*)'input_wrf.F: SIZE MISMATCH: namelist e_we = ',ide
948 CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
949 WRITE(wrf_err_message,*)'input_wrf.F: SIZE MISMATCH: input file WEST-EAST_GRID_DIMENSION = ',ide_compare
950 CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
951 CALL wrf_debug ( 0, "---- ERROR: Mismatch between namelist and input file dimensions" )
952 count_fatal_error = count_fatal_error + 1
953 ENDIF
954 IF ( jde .NE. jde_compare ) THEN
955 WRITE(wrf_err_message,*)'input_wrf.F: SIZE MISMATCH: namelist e_sn = ',jde
956 CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
957 WRITE(wrf_err_message,*)'input_wrf.F: SIZE MISMATCH: input file SOUTH-NORTH_GRID_DIMENSION = ',jde_compare
958 CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
959 CALL wrf_debug ( 0, "---- ERROR: Mismatch between namelist and input file dimensions" )
960 count_fatal_error = count_fatal_error + 1
961 ENDIF
962 IF ( config_flags%num_metgrid_levels .NE. kde_compare ) THEN
963 WRITE(wrf_err_message,*)'input_wrf.F: SIZE MISMATCH: namelist num_metgrid_levels = ',config_flags%num_metgrid_levels
964 CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
965 WRITE(wrf_err_message,*)'input_wrf.F: SIZE MISMATCH: input file BOTTOM-TOP_GRID_DIMENSION = ',kde_compare
966 CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
967 CALL wrf_debug ( 0, "---- ERROR: Mismatch between namelist and input file dimensions" )
968 count_fatal_error = count_fatal_error + 1
969 ENDIF
970 ENDIF
972 #endif
974 #if (DA_CORE == 1)
975 ! Test here to check that config_flags%hypsometric_opt in namelist
976 ! is equal to what is in the global attributes of the wrfinput files
978 IF ( switch .EQ. input_only ) THEN
979 CALL wrf_get_dom_ti_integer ( fid, 'HYPSOMETRIC_OPT', itmp, 1, icnt, ierr )
980 IF ( ierr .EQ. 0 ) THEN
981 WRITE(wrf_err_message,*)'input_wrf: global attribute HYPSOMETRIC_OPT returns ', itmp
982 CALL wrf_debug ( 300 , wrf_err_message )
983 IF ( config_flags%hypsometric_opt /= itmp ) THEN
984 call wrf_message("----------------- WARNING -------------------")
985 WRITE(wrf_err_message,'("namelist : hypsometric_opt = ",I10)') config_flags%hypsometric_opt
986 call wrf_message(wrf_err_message)
987 WRITE(wrf_err_message,'("input files : HYPSOMETRIC_OPT = ",I10, " (from wrfinput files).")') itmp
988 call wrf_message(wrf_err_message)
989 CALL wrf_debug ( 0, "---- ERROR: Mismatch between namelist and global attribute HYPSOMETRIC_OPT")
990 count_fatal_error = count_fatal_error + 1
991 END IF
992 ELSE
993 ! For WRFDA backward compatibility. If hypsometric_opt is not defined in the fg file, it is
994 ! pre-version 3.4 WRF input data. For older versions, hypsometric_opt should be 1.
995 hypsometric_opt = -1
996 CALL wrf_get_dom_ti_integer ( fid , 'HYPSOMETRIC_OPT' , hypsometric_opt, 1 , icnt , ierr )
997 IF ( ( hypsometric_opt .NE. 1 ) .AND. ( hypsometric_opt .NE. 2 ) ) THEN
998 grid%hypsometric_opt = 1
999 config_flags%hypsometric_opt = 1
1000 DO loop = 1 , grid%max_dom
1001 CALL nl_set_hypsometric_opt ( loop , 1 )
1002 END DO
1003 WRITE(wrf_err_message,*)'Background (fg) file appears to be from earlier than WRF V3.4;'
1004 call wrf_message(wrf_err_message)
1005 WRITE(wrf_err_message,*)'Resetting the hypsometric_opt from default value of 2 to 1'
1006 CALL wrf_message(wrf_err_message)
1007 END IF
1009 END IF
1010 END IF
1012 #endif
1014 #if ( ( EM_CORE == 1 ) && ( DA_CORE != 1 ) )
1015 IF ( ( switch .EQ. input_only ) .OR. ( switch .EQ. restart_only ) ) THEN
1017 ! Make sure for ARW ideal cases that the hypsometric option, the
1018 ! way that we integrate the height field, is set to 1. This is the
1019 ! method that is used in all of the "ideal" programs to get the
1020 ! base-state height (phb).
1022 CALL wrf_get_dom_ti_char ( fid , 'SIMULATION_INITIALIZATION_TYPE', sim_type , ierr )
1023 IF ( TRIM(sim_type) .EQ. "IDEALIZED DATA" ) THEN
1024 grid%this_is_an_ideal_run = .TRUE.
1025 ELSE IF ( TRIM(sim_type) .EQ. "REAL-DATA CASE" ) THEN
1026 grid%this_is_an_ideal_run = .FALSE.
1027 ELSE IF ( ierr .NE. 0 ) THEN
1028 CALL wrf_get_dom_ti_char ( fid , 'START_DATE' , input_name , ierr )
1029 grid%this_is_an_ideal_run = INDEX(TRIM(input_name) , '0001-' ) .NE. 0
1030 END IF
1032 IF ( grid%this_is_an_ideal_run ) THEN
1033 grid%hypsometric_opt = 1
1034 config_flags%hypsometric_opt = 1
1035 DO loop = 1 , grid%max_dom
1036 CALL nl_set_hypsometric_opt ( loop , 1 )
1037 END DO
1038 WRITE(wrf_err_message,*)'NOTE: Ideal cases always use hypsometric_opt=1, regardless of namelist setting'
1039 CALL wrf_debug( 1 , wrf_err_message )
1040 END IF
1041 END IF
1043 IF ( ( switch .EQ. input_only ) .AND. ( config_flags%io_form_input .EQ. 2 ) ) THEN
1045 ! For backward compatibility. If we do not find the hypsometric_opt defined
1046 ! in the input data, this is pre version 3.4. Most likely, the hypsometric_opt
1047 ! was the default value, 1.
1049 hypsometric_opt = -1
1050 CALL wrf_get_dom_ti_integer ( fid , 'HYPSOMETRIC_OPT' , hypsometric_opt , 1 , icnt , ierr )
1051 IF ( ( hypsometric_opt .NE. 1 ) .AND. ( hypsometric_opt .NE. 2 ) ) THEN
1052 grid%hypsometric_opt = 1
1053 config_flags%hypsometric_opt = 1
1054 DO loop = 1 , grid%max_dom
1055 CALL nl_set_hypsometric_opt ( loop , 1 )
1056 END DO
1057 WRITE(wrf_err_message,*)'Resetting the hypsometric_opt from default value of 2 to 1'
1058 CALL wrf_debug( 0 , wrf_err_message )
1059 END IF
1060 END IF
1062 ! In pre v4.0 data, the moist potential temperature was entirely handled in the model. In
1063 ! v4.0 and later, the pre-processors handle the moist potential temperature field directly.
1065 ! Input from old data
1066 !
1067 ! WRF NML Setting
1068 ! ---------------
1069 ! use_theta_m=1 | use_theta_m=0
1070 ! ---------------------------
1071 ! | | |
1072 ! thetam=1 | NO | OK |
1073 ! Input | | |
1074 ! NML ------------------------------------
1075 ! Setting | | |
1076 ! thetam=0 | NO | OK |
1077 ! | | |
1078 ! ---------------------------
1080 ! Old input data cannot be used when the namelist has use_theta_m=1
1082 CALL wrf_get_dom_ti_char ( fid , 'TITLE' , version_name , ierr )
1083 IF ( ( switch .EQ. input_only ) .AND. &
1084 ( INDEX(TRIM(version_name),' V4.' ) .EQ. 0 ) .AND. &
1085 ( config_flags%use_theta_m .EQ. 1 ) ) THEN
1086 CALL wrf_debug ( 0, "---- ERROR: Cannot have old input data when requesting use_theta_m=1" )
1087 count_fatal_error = count_fatal_error + 1
1088 END IF
1090 #endif
1092 ENDIF check_if_dryrun
1094 !
1095 ! This call to wrf_get_next_time will position the dataset over the next time-frame
1096 ! in the file and return the current_date, which is used as an argument to the
1097 ! read_field routines in the blocks of code included below. Note that we read the
1098 ! next time *after* all the meta data has been read. This is only important for the
1099 ! WRF internal I/O format because it is order-dependent. Other formats shouldn't care
1100 ! about this.
1101 !
1103 3003 continue
1105 CALL wrf_get_next_time(fid, current_date , ierr)
1106 WRITE(wrf_err_message,*)fid,' input_wrf: wrf_get_next_time current_date: ',current_date(1:19),' Status = ',ierr
1107 CALL wrf_debug ( 300 , TRIM(wrf_err_message ) )
1108 IF ( ierr .NE. 0 .AND. ierr .NE. WRF_WARN_NOTSUPPORTED .AND. ierr .NE. WRF_WARN_DRYRUN_READ ) THEN
1109 CALL wrf_message ( TRIM(wrf_err_message ) )
1110 IF ( switch .EQ. boundary_only ) THEN
1111 WRITE(wrf_err_message,*) '---- ERROR: Ran out of valid boundary conditions in file ',TRIM(fname)
1112 CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
1113 ELSE
1114 WRITE(wrf_err_message,*) '---- ERROR: Could not find matching time in input file ',TRIM(fname)
1115 CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
1116 count_fatal_error = count_fatal_error + 1
1117 ENDIF
1118 ELSE IF ( ierr .NE. WRF_WARN_NOTSUPPORTED .AND. ierr .NE. WRF_WARN_DRYRUN_READ) THEN
1119 !
1120 ! check input time against domain time (which will be start time at beginning, see share/set_timekeeping.F)
1121 ! JM 20040511
1122 !
1123 SELECT CASE ( switch )
1124 CASE ( input_only, auxinput1_only, auxinput2_only, &
1125 auxinput3_only, auxinput4_only, auxinput5_only, &
1126 auxinput6_only, auxinput7_only, auxinput8_only, &
1127 auxinput9_only, auxinput10_only, auxinput17_only )
1128 #if ( WRF_CHEM == 1 )
1129 IF( (config_flags%io_style_emissions .eq. 1) .and. &
1130 ((switch.eq.auxinput5_only) .or. (switch.eq.auxinput6_only) .or. &
1131 (switch.eq.auxinput7_only) .or. (switch.eq.auxinput8_only)) ) then
1132 CALL wrf_message( "**WARNING** Time in input file not being checked **WARNING**" )
1133 ELSE
1134 #endif
1135 CALL wrf_atotime( current_date(1:19), time )
1136 CALL domain_clock_get( grid, current_time=currtime, &
1137 current_timestr=currtimestr )
1138 #if (DA_CORE != 1)
1139 IF ( (switch .EQ. input_only) .and. (grid%id .EQ. 1) .and. (grid%itimestep .EQ. 0) ) THEN
1140 WRITE( wrf_err_message , * ) 'CURRENT DATE = ',TRIM( currtimestr )
1141 CALL wrf_message ( trim(wrf_err_message) )
1142 WRITE( wrf_err_message , * ) 'SIMULATION START DATE = ', simulation_start_date(1:19)
1143 CALL wrf_message ( TRIM(wrf_err_message ) )
1144 END IF
1145 ! Don't perform the check for WRFVAR, as we're not passing the right dates
1146 ! around
1147 CALL domain_clockprint(150, grid, &
1148 'DEBUG input_wrf(): get CurrTime from clock,')
1149 IF ( time .NE. currtime ) THEN
1150 WRITE( wrf_err_message , * )'Time in file: ',trim( current_date(1:19) )
1151 CALL wrf_message ( trim(wrf_err_message) )
1152 WRITE( wrf_err_message , * )'Time on domain: ',trim( currtimestr )
1153 CALL wrf_message ( trim(wrf_err_message) )
1154 CALL wrf_message( "**WARNING** Time in input file not equal to time on domain **WARNING**" )
1155 WRITE(wrf_err_message,*) "**WARNING** Trying next time in file ",TRIM(fname)," ..."
1156 CALL wrf_message( TRIM(wrf_err_message) )
1157 GOTO 3003
1158 ENDIF
1159 #endif
1160 #if ( WRF_CHEM == 1 )
1161 ENDIF
1162 #endif
1163 CASE DEFAULT
1164 END SELECT
1165 ENDIF
1167 ! set the lbc time interval fields in the domain data structure
1168 ! these time values are checked as stopping condition for the while loop in
1169 ! latbound_in() defined in share/medation_integrate.F, which is used to
1170 ! iterate forward to the correct interval in the input LBC file
1171 !
1172 IF ( switch .EQ. boundary_only ) THEN
1173 IF ( config_flags%restart ) THEN
1174 ! get WRF time of current_date position in boundary file
1175 CALL wrf_atotime( current_date(1:19), time )
1176 ! jump straight to the restart time
1177 CALL domain_clock_get( grid, current_time=currentTime, &
1178 current_timestr=currtimestr )
1179 write(wrf_err_message, '(4a)') "WRF restart, LBC starts at ", &
1180 & trim(current_date), " and restart starts at ", trim(currtimestr)
1181 CALL wrf_debug( 0 , wrf_err_message )
1182 CALL wrf_get_dom_td_char ( fid , 'THISBDYTIME' , current_date(1:19), this_datestr , ierr )
1183 CALL wrf_atotime( this_datestr(1:19), grid%this_bdy_time )
1184 CALL wrf_get_dom_td_char ( fid , 'NEXTBDYTIME' , current_date(1:19), next_datestr , ierr )
1185 CALL wrf_atotime( next_datestr(1:19), grid%next_bdy_time )
1187 WRITE ( wrf_err_message , * ) 'LBC for restart: Starting valid date = ',this_datestr(1:19),', Ending valid date = ',next_datestr(1:19)
1188 CALL wrf_message( TRIM(wrf_err_message) )
1189 WRITE ( wrf_err_message , * ) 'LBC for restart: Restart time = ',trim(currtimestr)
1190 CALL wrf_message( TRIM(wrf_err_message) )
1192 IF ( ( grid%this_bdy_time .LE. currentTime ) .AND. ( grid%next_bdy_time .GT. currentTime ) ) THEN
1193 WRITE ( wrf_err_message , * ) 'LBC for restart: Found the correct bounding LBC time periods'
1194 CALL wrf_message( TRIM(wrf_err_message) )
1195 ELSE
1197 WRITE ( wrf_err_message , * ) 'LBC for restart: Looking for a bounding time'
1198 CALL wrf_message( TRIM(wrf_err_message) )
1200 ! While the lateral BC time is less than the restart time, advance forward to the next LBC time.
1202 icount = 0
1203 DO WHILE ( ( currentTime .GE. grid%next_bdy_time ) .AND. ( icount < 60000 ) )
1204 CALL wrf_get_next_time(fid, current_date , ierr)
1205 IF ( ierr .NE. 0 ) THEN
1206 CALL wrf_debug ( 0, '---- ERROR: Cannot find a valid time to start the LBC during this restart, likely ran out of time periods to test' )
1207 count_fatal_error = count_fatal_error + 1
1208 END IF
1209 CALL wrf_get_dom_td_char ( fid , 'THISBDYTIME' , current_date(1:19), this_datestr , ierr )
1210 CALL wrf_get_dom_td_char ( fid , 'NEXTBDYTIME' , current_date(1:19), next_datestr , ierr )
1211 CALL wrf_atotime( next_datestr(1:19), grid%next_bdy_time )
1212 WRITE ( wrf_err_message , * ) 'LBC for restart: Starting valid date = ',this_datestr(1:19),', Ending valid date = ',next_datestr(1:19)
1213 CALL wrf_message( TRIM(wrf_err_message) )
1214 icount = icount + 1
1215 END DO
1217 ! Now the LBC time either matches or is beyond the restart time. If it matches, we are at the
1218 ! right time. If we have gone too far, then back up one time period, and we are good to go.
1220 IF ( time .eq. currentTime ) THEN
1221 CALL wrf_debug ( 0 , 'Found correct time, LBC matches the restart interval.' )
1222 ELSE IF ( time .gt. currentTime ) THEN
1223 CALL wrf_debug ( 0 , 'Went one LBC interval too far, backing up for restart.' )
1224 CALL wrf_get_previous_time(fid, current_date , ierr)
1225 IF ( ierr .EQ. 0 ) THEN
1226 CALL wrf_atotime(current_date(1:19), time)
1227 WRITE(wrf_err_message,*) 'LBC: wrf_get_prev_time current_date: ',&
1228 & current_date(1:19),' Status = ',ierr
1229 CALL wrf_debug ( 0 , TRIM(wrf_err_message ) )
1230 CALL wrf_debug ( 0 , 'LBC is now correctly positioned for requested restart time' )
1231 ELSE
1232 CALL wrf_debug ( 0, '---- ERROR: Problems backing up in the LBC file to find starting location for restart' )
1233 count_fatal_error = count_fatal_error + 1
1234 END IF
1235 END IF
1236 END IF
1238 CALL wrf_get_dom_td_char ( fid , 'THISBDYTIME' , current_date(1:19), this_datestr , ierr )
1239 CALL wrf_atotime( this_datestr(1:19), grid%this_bdy_time )
1240 CALL wrf_get_dom_td_char ( fid , 'NEXTBDYTIME' , current_date(1:19), next_datestr , ierr )
1241 CALL wrf_atotime( next_datestr(1:19), grid%next_bdy_time )
1242 WRITE ( wrf_err_message , * ) 'LBC for restart: Found the correct bounding LBC time periods for restart time = ',trim(currtimestr)
1243 CALL wrf_message ( TRIM(wrf_err_message) )
1245 ELSE IF ( .NOT. config_flags%restart ) THEN
1246 CALL domain_clock_get( grid, current_time=currentTime )
1247 CALL wrf_get_dom_td_char ( fid , 'THISBDYTIME' , current_date(1:19), this_datestr , ierr )
1248 CALL wrf_atotime( this_datestr(1:19), grid%this_bdy_time )
1249 CALL wrf_get_dom_td_char ( fid , 'NEXTBDYTIME' , current_date(1:19), next_datestr , ierr )
1250 CALL wrf_atotime( next_datestr(1:19), grid%next_bdy_time )
1251 END IF
1252 #if (DA_CORE != 1)
1253 #if ( WRFPLUS == 1 )
1254 IF( config_flags%dyn_opt .NE. dyn_em_ad .AND. currentTime .GE. grid%next_bdy_time ) THEN
1255 #else
1256 IF( currentTime .GE. grid%next_bdy_time ) THEN
1257 #endif
1258 IF ( wrf_dm_on_monitor() ) THEN
1259 write(a_message,*) 'THIS TIME ',this_datestr(1:19),', NEXT TIME ',next_datestr(1:19)
1260 CALL wrf_message ( a_message )
1261 END IF
1262 RETURN
1263 ENDIF
1264 #if ( WRFPLUS == 1 )
1265 IF( config_flags%dyn_opt .EQ. dyn_em_ad .AND. currentTime .GT. grid%next_bdy_time ) THEN
1266 IF ( wrf_dm_on_monitor() ) write(0,*) 'THIS TIME ',this_datestr(1:19),'NEXT TIME ',next_datestr(1:19)
1267 RETURN
1268 ENDIF
1269 #endif
1270 #endif
1271 ENDIF
1273 #if ( ( EM_CORE == 1 ) && ( DA_CORE != 1 ) )
1274 ! Vertical interpolation space is required if specified by user.
1276 n_ref_m = config_flags%vert_refine_fact
1277 #else
1278 ! Default value indicating no vertical interpolation required.
1280 n_ref_m = 0
1281 #endif
1283 ! This test should go after all of the metadata is input, and before the gridded input is ingested.
1285 IF ( count_fatal_error .GT. 0 ) THEN
1286 WRITE (wrf_err_message, FMT='(A,I6, A)') 'NOTE: ', count_fatal_error, ' namelist vs input data inconsistencies found.'
1287 CALL wrf_message ( wrf_err_message )
1288 WRITE (wrf_err_message, FMT='(A,I6, A)') 'NOTE: Please check and reset these options'
1289 CALL wrf_error_fatal ( wrf_err_message )
1290 END IF
1292 IF ( (first_input .LE. switch .AND. switch .LE. last_input) .OR. &
1293 (first_history .LE. switch .AND. switch .LE. last_history) .OR. &
1294 switch .EQ. restart_only ) THEN
1295 newswitch = switch
1296 p => grid%head_statevars%next
1297 DO WHILE ( ASSOCIATED( p ) )
1298 IF ( p%ProcOrient .NE. 'X' .AND. p%ProcOrient .NE. 'Y' ) THEN ! no I/O for xposed variables
1299 IF ( p%Ndim .EQ. 0 ) THEN
1300 IF ((p%Restart.AND.switch.EQ.restart_only).OR.on_stream( p%streams,newswitch)) THEN
1301 IF ( in_use_for_config(grid%id,TRIM(p%VarName)) ) THEN
1302 IF (p%Ntl.GT.0.AND.switch.NE.restart_only)dname=dname(1:len(TRIM(dname))-2)
1303 dname = p%DataName
1304 IF (switch.EQ.restart_only.OR.p%Ntl/100.EQ.mod(p%Ntl,100)) THEN
1305 IF ( p%Type .EQ. 'r' ) THEN
1306 CALL wrf_ext_read_field ( &
1307 fid , & ! DataHandle
1308 current_date(1:19) , & ! DateStr
1309 TRIM(dname) , & ! Data Name
1310 p%rfield_0d , & ! Field
1311 WRF_FLOAT , & ! FieldType
1312 grid , & ! grid
1313 grid%domdesc , & ! domdesc
1314 grid%bdy_mask , & ! bdy_mask
1315 '0' , & ! MemoryOrder
1316 '' , & ! Stagger
1317 __FILE__ // ' reading 0d real ' // TRIM(p%VarName) , & ! Debug message
1318 1 , 1 , 1 , 1 , 1 , 1 , &
1319 1 , 1 , 1 , 1 , 1 , 1 , &
1320 1 , 1 , 1 , 1 , 1 , 1 , &
1321 ierr )
1322 ELSE IF ( p%Type .EQ. 'd' ) THEN
1323 CALL wrf_ext_read_field ( &
1324 fid , & ! DataHandle
1325 current_date(1:19) , & ! DateStr
1326 TRIM(dname) , & ! Data Name
1327 p%dfield_0d , & ! Field
1328 WRF_DOUBLE , & ! FieldType
1329 grid , & ! grid
1330 grid%domdesc , & ! domdesc
1331 grid%bdy_mask , & ! bdy_mask
1332 '0' , & ! MemoryOrder
1333 '' , & ! Stagger
1334 __FILE__ // ' reading 0d double ' // TRIM(p%VarName) , & ! Debug message
1335 1 , 1 , 1 , 1 , 1 , 1 , &
1336 1 , 1 , 1 , 1 , 1 , 1 , &
1337 1 , 1 , 1 , 1 , 1 , 1 , &
1338 ierr )
1339 ELSE IF ( p%Type .EQ. 'i' ) THEN
1340 CALL wrf_ext_read_field ( &
1341 fid , & ! DataHandle
1342 current_date(1:19) , & ! DateStr
1343 TRIM(dname) , & ! Data Name
1344 p%ifield_0d , & ! Field
1345 WRF_INTEGER , & ! FieldType
1346 grid , & ! grid
1347 grid%domdesc , & ! domdesc
1348 grid%bdy_mask , & ! bdy_mask
1349 '0' , & ! MemoryOrder
1350 '' , & ! Stagger
1351 __FILE__ // ' reading 0d integer ' // TRIM(p%VarName) , & ! Debug message
1352 1 , 1 , 1 , 1 , 1 , 1 , &
1353 1 , 1 , 1 , 1 , 1 , 1 , &
1354 1 , 1 , 1 , 1 , 1 , 1 , &
1355 ierr )
1356 ELSE IF ( p%Type .EQ. 'l' ) THEN
1357 CALL wrf_ext_read_field ( &
1358 fid , & ! DataHandle
1359 current_date(1:19) , & ! DateStr
1360 TRIM(dname) , & ! Data Name
1361 p%lfield_0d , & ! Field
1362 WRF_LOGICAL , & ! FieldType
1363 grid , & ! grid
1364 grid%domdesc , & ! domdesc
1365 grid%bdy_mask , & ! bdy_mask
1366 '0' , & ! MemoryOrder
1367 '' , & ! Stagger
1368 __FILE__ // ' reading 0d logical ' // TRIM(p%VarName) , & ! Debug message
1369 1 , 1 , 1 , 1 , 1 , 1 , &
1370 1 , 1 , 1 , 1 , 1 , 1 , &
1371 1 , 1 , 1 , 1 , 1 , 1 , &
1372 ierr )
1373 ENDIF
1374 ENDIF
1375 ENDIF
1376 ENDIF
1377 ELSE IF ( p%Ndim .EQ. 1 ) THEN
1378 IF ((p%Restart.AND.switch.EQ.restart_only).OR.on_stream( p%streams,newswitch)) THEN
1379 IF ( in_use_for_config(grid%id,TRIM(p%VarName)) ) THEN
1380 IF (switch.EQ.restart_only.OR.p%Ntl/100.EQ.mod(p%Ntl,100)) THEN
1381 dname = p%DataName
1382 IF (p%Ntl.GT.0.AND.switch.NE.restart_only)dname=dname(1:len(TRIM(dname))-2)
1383 memord = p%MemoryOrder
1385 i_inter = 0
1386 #if ( ( EM_CORE == 1 ) && ( DA_CORE != 1 ) )
1387 ! Vertical interpolation space is required if specified by user.
1389 if( TRIM(p%dimname1).EQ.'bottom_top'.OR.TRIM(p%dimname1).EQ.'bottom_top_stag') i_inter = 1
1390 #endif
1392 IF ( p%Type .EQ. 'r' ) THEN
1393 IF( (i_inter.eq.1.and.n_ref_m.ge.2).and.(switch.eq.history_only) ) THEN
1394 em1_c = (p%em1 - 1)/n_ref_m +1
1395 ed1_c = em1_c
1396 ep1_c = em1_c
1397 if (TRIM(p%dimname1).EQ.'bottom_top') then
1398 ed1_c = em1_c-1
1399 ep1_c = em1_c-1
1400 endif
1401 allocate (f_vint_1d(em1_c))
1403 CALL wrf_ext_read_field ( &
1404 fid , & ! DataHandle
1405 current_date(1:19) , & ! DateStr
1406 TRIM(dname) , & ! Data Name
1407 f_vint_1d , & ! Field
1408 WRF_FLOAT , & ! FieldType
1409 grid , & ! grid
1410 grid%domdesc , & ! domdesc
1411 grid%bdy_mask , & ! bdy_mask
1412 TRIM(memord) , & ! MemoryOrder
1413 p%Stagger , & ! Stagger
1414 __FILE__ // ' reading 1d real ' // TRIM(p%VarName) , & ! Debug message
1415 p%sd1 , ed1_c , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1416 p%sm1 , em1_c , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1417 p%sp1 , ep1_c , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1418 ierr )
1420 do k=1,ed1_c
1421 p%rfield_1d(k) = f_vint_1d(k)
1422 enddo
1423 deallocate (f_vint_1d)
1425 ELSE
1426 CALL wrf_ext_read_field ( &
1427 fid , & ! DataHandle
1428 current_date(1:19) , & ! DateStr
1429 TRIM(dname) , & ! Data Name
1430 p%rfield_1d , & ! Field
1431 WRF_FLOAT , & ! FieldType
1432 grid , & ! grid
1433 grid%domdesc , & ! domdesc
1434 grid%bdy_mask , & ! bdy_mask
1435 TRIM(memord) , & ! MemoryOrder
1436 p%Stagger , & ! Stagger
1437 __FILE__ // ' reading 1d real ' // TRIM(p%VarName) , & ! Debug message
1438 p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1439 p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1440 p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1441 ierr )
1442 END IF
1443 ELSE IF ( p%Type .EQ. 'd' ) THEN
1444 CALL wrf_ext_read_field ( &
1445 fid , & ! DataHandle
1446 current_date(1:19) , & ! DateStr
1447 TRIM(dname) , & ! Data Name
1448 p%dfield_1d , & ! Field
1449 WRF_DOUBLE , & ! FieldType
1450 grid , & ! grid
1451 grid%domdesc , & ! domdesc
1452 grid%bdy_mask , & ! bdy_mask
1453 TRIM(memord) , & ! MemoryOrder
1454 TRIM(p%Stagger) , & ! Stagger
1455 __FILE__ // ' reading 1d double ' // TRIM(p%VarName) , & ! Debug message
1456 p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1457 p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1458 p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1459 ierr )
1460 ELSE IF ( p%Type .EQ. 'i' ) THEN
1461 CALL wrf_ext_read_field ( &
1462 fid , & ! DataHandle
1463 current_date(1:19) , & ! DateStr
1464 TRIM(dname) , & ! Data Name
1465 p%ifield_1d , & ! Field
1466 WRF_INTEGER , & ! FieldType
1467 grid , & ! grid
1468 grid%domdesc , & ! domdesc
1469 grid%bdy_mask , & ! bdy_mask
1470 TRIM(memord) , & ! MemoryOrder
1471 TRIM(p%Stagger) , & ! Stagger
1472 __FILE__ // ' reading 1d integer ' // TRIM(p%VarName) , & ! Debug message
1473 p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1474 p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1475 p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1476 ierr )
1477 ELSE IF ( p%Type .EQ. 'l' ) THEN
1478 CALL wrf_ext_read_field ( &
1479 fid , & ! DataHandle
1480 current_date(1:19) , & ! DateStr
1481 TRIM(dname) , & ! Data Name
1482 p%lfield_1d , & ! Field
1483 WRF_LOGICAL , & ! FieldType
1484 grid , & ! grid
1485 grid%domdesc , & ! domdesc
1486 grid%bdy_mask , & ! bdy_mask
1487 TRIM(memord) , & ! MemoryOrder
1488 TRIM(p%Stagger) , & ! Stagger
1489 __FILE__ // ' reading 1d logical ' // TRIM(p%VarName) , & ! Debug message
1490 p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1491 p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1492 p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1493 ierr )
1494 ENDIF
1495 ENDIF
1496 ENDIF
1497 ENDIF
1498 ELSE IF ( p%Ndim .EQ. 2 ) THEN
1499 IF ((p%Restart.AND.switch.EQ.restart_only).OR.on_stream( p%streams,newswitch)) THEN
1500 IF ( in_use_for_config(grid%id,TRIM(p%VarName)) .AND. &
1501 ( .NOT. p%subgrid_x .OR. (p%subgrid_x .AND. grid%sr_x .GT. 0) ) .AND. &
1502 ( .NOT. p%subgrid_y .OR. (p%subgrid_y .AND. grid%sr_y .GT. 0) ) &
1503 ) THEN
1504 IF (switch.EQ.restart_only.OR.p%Ntl/100.EQ.mod(p%Ntl,100)) THEN
1505 dname = p%DataName
1506 IF (p%Ntl.GT.0.AND.switch.NE.restart_only)dname=dname(1:len(TRIM(dname))-2)
1507 memord = p%MemoryOrder
1508 IF ( p%Type .EQ. 'r' ) THEN
1509 CALL wrf_ext_read_field ( &
1510 fid , & ! DataHandle
1511 current_date(1:19) , & ! DateStr
1512 TRIM(dname) , & ! Data Name
1513 p%rfield_2d , & ! Field
1514 WRF_FLOAT , & ! FieldType
1515 grid , & ! grid
1516 grid%domdesc , & ! domdesc
1517 grid%bdy_mask , & ! bdy_mask
1518 TRIM(memord) , & ! MemoryOrder
1519 TRIM(p%Stagger) , & ! Stagger
1520 __FILE__ // ' reading 2d real ' // TRIM(p%VarName) , & ! Debug message
1521 p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1522 p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1523 p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1524 ierr )
1525 ELSE IF ( p%Type .EQ. 'd' ) THEN
1526 CALL wrf_ext_read_field ( &
1527 fid , & ! DataHandle
1528 current_date(1:19) , & ! DateStr
1529 TRIM(dname) , & ! Data Name
1530 p%dfield_2d , & ! Field
1531 WRF_DOUBLE , & ! FieldType
1532 grid , & ! grid
1533 grid%domdesc , & ! domdesc
1534 grid%bdy_mask , & ! bdy_mask
1535 TRIM(memord) , & ! MemoryOrder
1536 TRIM(p%Stagger) , & ! Stagger
1537 __FILE__ // ' reading 2d double ' // TRIM(p%VarName) , & ! Debug message
1538 p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1539 p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1540 p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1541 ierr )
1542 ELSE IF ( p%Type .EQ. 'i' ) THEN
1543 CALL wrf_ext_read_field ( &
1544 fid , & ! DataHandle
1545 current_date(1:19) , & ! DateStr
1546 TRIM(dname) , & ! Data Name
1547 p%ifield_2d , & ! Field
1548 WRF_INTEGER , & ! FieldType
1549 grid , & ! grid
1550 grid%domdesc , & ! domdesc
1551 grid%bdy_mask , & ! bdy_mask
1552 TRIM(memord) , & ! MemoryOrder
1553 TRIM(p%Stagger) , & ! Stagger
1554 __FILE__ // ' reading 2d integer ' // TRIM(p%VarName) , & ! Debug message
1555 p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1556 p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1557 p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1558 ierr )
1559 ELSE IF ( p%Type .EQ. 'l' ) THEN
1560 CALL wrf_ext_read_field ( &
1561 fid , & ! DataHandle
1562 current_date(1:19) , & ! DateStr
1563 TRIM(dname) , & ! Data Name
1564 p%lfield_2d , & ! Field
1565 WRF_LOGICAL , & ! FieldType
1566 grid , & ! grid
1567 grid%domdesc , & ! domdesc
1568 grid%bdy_mask , & ! bdy_mask
1569 TRIM(memord) , & ! MemoryOrder
1570 TRIM(p%Stagger) , & ! Stagger
1571 __FILE__ // ' reading 2d logical ' // TRIM(p%VarName) , & ! Debug message
1572 p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1573 p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1574 p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1575 ierr )
1576 ENDIF
1577 ENDIF
1578 ENDIF
1579 ENDIF
1580 ELSE IF ( p%Ndim .EQ. 3 ) THEN
1581 IF ((p%Restart.AND.switch.EQ.restart_only).OR.on_stream( p%streams,newswitch)) THEN
1582 IF ( in_use_for_config(grid%id,TRIM(p%VarName)) .AND. &
1583 ( .NOT. p%subgrid_x .OR. (p%subgrid_x .AND. grid%sr_x .GT. 0) ) .AND. &
1584 ( .NOT. p%subgrid_y .OR. (p%subgrid_y .AND. grid%sr_y .GT. 0) ) &
1585 ) THEN
1586 IF (switch.EQ.restart_only.OR.p%Ntl/100.EQ.mod(p%Ntl,100)) THEN
1587 dname = p%DataName
1588 IF (p%Ntl.GT.0.AND.switch.NE.restart_only)dname=dname(1:len(TRIM(dname))-2)
1589 memord = p%MemoryOrder
1591 i_inter = 0
1592 #if ( ( EM_CORE == 1 ) && ( DA_CORE != 1 ) )
1593 ! Vertical interpolation space is required if specified by user.
1595 if( TRIM(p%dimname2).EQ.'bottom_top'.OR.TRIM(p%dimname2).EQ.'bottom_top_stag') i_inter = 1
1596 #endif
1598 IF ( p%Type .EQ. 'r' ) THEN
1599 IF( (i_inter.eq.1.and.n_ref_m.ge.2).and.(switch.eq.history_only) ) then
1600 em2_c = (p%em2 - 1)/n_ref_m +1
1601 ed2_c = em2_c
1602 ep2_c = em2_c
1603 if (TRIM(p%dimname2).EQ.'bottom_top') then
1604 ed2_c = em2_c-1
1605 ep2_c = em2_c-1
1606 endif
1607 allocate (f_vint_3d(p%sm1:p%em1,em2_c,p%sm3:p%em3))
1608 CALL wrf_ext_read_field ( &
1609 fid , & ! DataHandle
1610 current_date(1:19) , & ! DateStr
1611 TRIM(dname) , & ! Data Name
1612 f_vint_3d , & ! Field
1613 WRF_FLOAT , & ! FieldType
1614 grid , & ! grid
1615 grid%domdesc , & ! domdesc
1616 grid%bdy_mask , & ! bdy_mask
1617 TRIM(memord) , & ! MemoryOrder
1618 TRIM(p%Stagger) , & ! Stagger
1619 __FILE__ // ' reading 3d real ' // TRIM(p%VarName) , & ! Debug message
1620 p%sd1 , p%ed1 , p%sd2 , ed2_c , p%sd3 , p%ed3 , &
1621 p%sm1 , p%em1 , p%sm2 , em2_c , p%sm3 , p%em3 , &
1622 p%sp1 , p%ep1 , p%sp2 , ep2_c , p%sp3 , p%ep3 , &
1623 ierr )
1625 do j = p%sm3,p%em3
1626 do k = 1,ed2_c
1627 do i = p%sm1,p%em1
1628 p%rfield_3d(i,k,j) = f_vint_3d(i,k,j)
1629 enddo
1630 enddo
1631 enddo
1632 deallocate (f_vint_3d)
1633 ELSE
1634 CALL wrf_ext_read_field ( &
1635 fid , & ! DataHandle
1636 current_date(1:19) , & ! DateStr
1637 TRIM(dname) , & ! Data Name
1638 p%rfield_3d , & ! Field
1639 WRF_FLOAT , & ! FieldType
1640 grid , & ! grid
1641 grid%domdesc , & ! domdesc
1642 grid%bdy_mask , & ! bdy_mask
1643 TRIM(memord) , & ! MemoryOrder
1644 TRIM(p%Stagger) , & ! Stagger
1645 __FILE__ // ' reading 3d real ' // TRIM(p%VarName) , & ! Debug message
1646 p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1647 p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1648 p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1649 ierr )
1650 ENDIF
1651 ELSE IF ( p%Type .EQ. 'd' ) THEN
1652 CALL wrf_ext_read_field ( &
1653 fid , & ! DataHandle
1654 current_date(1:19) , & ! DateStr
1655 TRIM(dname) , & ! Data Name
1656 p%dfield_3d , & ! Field
1657 WRF_DOUBLE , & ! FieldType
1658 grid%communicator , & ! Comm
1659 grid%iocommunicator , & ! Comm
1660 grid%domdesc , & ! Comm
1661 grid%bdy_mask , & ! bdy_mask
1662 TRIM(memord) , & ! MemoryOrder
1663 TRIM(p%Stagger) , & ! Stagger
1664 __FILE__ // ' reading 3d double ' // TRIM(p%VarName) , & ! Debug message
1665 p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1666 p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1667 p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1668 ierr )
1669 ELSE IF ( p%Type .EQ. 'i' ) THEN
1670 CALL wrf_ext_read_field ( &
1671 fid , & ! DataHandle
1672 current_date(1:19) , & ! DateStr
1673 TRIM(dname) , & ! Data Name
1674 p%ifield_3d , & ! Field
1675 WRF_INTEGER , & ! FieldType
1676 grid , & ! grid
1677 grid%domdesc , & ! domdesc
1678 grid%bdy_mask , & ! bdy_mask
1679 TRIM(memord) , & ! MemoryOrder
1680 TRIM(p%Stagger) , & ! Stagger
1681 __FILE__ // ' reading 3d integer ' // TRIM(p%VarName) , & ! Debug message
1682 p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1683 p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1684 p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1685 ierr )
1686 ! NOTE no io on logical arrays greater than 2d
1687 ENDIF
1688 ENDIF
1689 ENDIF
1690 ENDIF
1691 ELSE IF ( p%Ndim .EQ. 4 .AND. p%scalar_array ) THEN
1692 ! Use a different read routine, wrf_ext_read_field_arr, and pass in the
1693 ! tracer indeces so that p%rfield_4d can be passsed in without arguments,
1694 ! avoiding the possiblity of a copy-in/copy-out problem for some compilers.
1695 ! JM 20091208
1696 DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id)
1697 IF ((p%Restart.AND.switch.EQ.restart_only).OR.on_stream( p%streams_table(grid%id,itrace)%stream,newswitch)) THEN
1698 dname = p%dname_table( grid%id, itrace )
1699 IF (p%Ntl.GT.0.AND.switch.NE.restart_only)dname=dname(1:len(TRIM(dname))-2)
1700 memord = p%MemoryOrder
1702 i_inter = 0
1703 #if ( ( EM_CORE == 1 ) && ( DA_CORE != 1 ) )
1704 ! Vertical interpolation space is required if specified by user.
1706 if( TRIM(p%dimname2).EQ.'bottom_top'.OR.TRIM(p%dimname2).EQ.'bottom_top_stag') i_inter = 1
1707 #endif
1709 IF ( p%Type .EQ. 'r' ) THEN
1710 IF( (i_inter.eq.1.and.n_ref_m.ge.2).and.(switch.eq.history_only) ) then
1711 em2_c = (p%em2 - 1)/n_ref_m +1
1712 ed2_c = em2_c
1713 ep2_c = em2_c
1714 if (TRIM(p%dimname2).EQ.'bottom_top') then
1715 ed2_c = em2_c-1
1716 ep2_c = em2_c-1
1717 endif
1718 allocate (f_vint_4d(p%sm1:p%em1,em2_c,p%sm3:p%em3,p%num_table(grid%id)))
1720 CALL wrf_ext_read_field_arr ( &
1721 fid , & ! DataHandle
1722 current_date(1:19) , & ! DateStr
1723 TRIM(dname) , & ! Data Name
1724 f_vint_4d , & ! Field
1725 itrace, 1, 1, 1 , & ! see comment above
1726 1, 1, 1 , & ! see comment above
1727 RWORDSIZE , &
1728 WRF_FLOAT , & ! FieldType
1729 grid , & ! grid
1730 grid%domdesc , & ! domdesc
1731 grid%bdy_mask , & ! bdy_mask
1732 TRIM(memord) , & ! MemoryOrder
1733 TRIM(p%Stagger) , & ! Stagger
1734 __FILE__ // ' reading 4d real ' // TRIM(p%dname_table(grid%id,itrace)) , & ! Debug message
1735 p%sd1 , p%ed1 , p%sd2 , ed2_c , p%sd3 , p%ed3 , &
1736 p%sm1 , p%em1 , p%sm2 , em2_c , p%sm3 , p%em3 , &
1737 p%sp1 , p%ep1 , p%sp2 , ep2_c , p%sp3 , p%ep3 , &
1738 ierr )
1739 do j = p%sm3,p%em3
1740 do k = 1,ed2_c
1741 do i = p%sm1,p%em1
1742 p%rfield_4d(i,k,j,itrace) = f_vint_4d(i,k,j,itrace)
1743 enddo
1744 enddo
1745 enddo
1746 deallocate (f_vint_4d)
1747 ELSE
1748 CALL wrf_ext_read_field_arr ( &
1749 fid , & ! DataHandle
1750 current_date(1:19) , & ! DateStr
1751 TRIM(dname) , & ! Data Name
1752 p%rfield_4d , & ! Field
1753 itrace, 1, 1, 1 , & ! see comment above
1754 1, 1, 1 , & ! see comment above
1755 RWORDSIZE , &
1756 WRF_FLOAT , & ! FieldType
1757 grid , & ! grid
1758 grid%domdesc , & ! domdesc
1759 grid%bdy_mask , & ! bdy_mask
1760 TRIM(memord) , & ! MemoryOrder
1761 TRIM(p%Stagger) , & ! Stagger
1762 __FILE__ // ' reading 4d real ' // TRIM(p%dname_table(grid%id,itrace)) , & ! Debug message
1763 p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1764 p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1765 p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1766 ierr )
1767 ENDIF
1768 ELSE IF ( p%Type .EQ. 'd' ) THEN
1769 CALL wrf_ext_read_field_arr ( &
1770 fid , & ! DataHandle
1771 current_date(1:19) , & ! DateStr
1772 TRIM(dname) , & ! Data Name
1773 p%dfield_4d , & ! Field
1774 itrace, 1, 1, 1 , & ! see comment above
1775 1, 1, 1 , & ! see comment above
1776 DWORDSIZE , &
1777 WRF_DOUBLE , & ! FieldType
1778 grid , & ! grid
1779 grid%domdesc , & ! domdesc
1780 grid%bdy_mask , & ! bdy_mask
1781 TRIM(memord) , & ! MemoryOrder
1782 TRIM(p%Stagger) , & ! Stagger
1783 __FILE__ // ' reading 4d double ' // TRIM(p%dname_table(grid%id,itrace)) , & ! Debug message
1784 p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1785 p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1786 p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1787 ierr )
1788 ELSE IF ( p%Type .EQ. 'i' ) THEN
1789 CALL wrf_ext_read_field_arr ( &
1790 fid , & ! DataHandle
1791 current_date(1:19) , & ! DateStr
1792 TRIM(dname) , & ! Data Name
1793 p%ifield_4d , & ! Field
1794 itrace, 1, 1, 1 , & ! see comment above
1795 1, 1, 1 , & ! see comment above
1796 IWORDSIZE , &
1797 WRF_INTEGER , & ! FieldType
1798 grid , & ! grid
1799 grid%domdesc , & ! domdesc
1800 grid%bdy_mask , & ! bdy_mask
1801 TRIM(memord) , & ! MemoryOrder
1802 TRIM(p%Stagger) , & ! Stagger
1803 __FILE__ // ' reading 4d integer ' // TRIM(p%dname_table(grid%id,itrace)) , & ! Debug message
1804 p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1805 p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1806 p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1807 ierr )
1808 ENDIF
1809 ENDIF
1810 ENDDO ! loop over tracers
1811 ENDIF
1812 ENDIF
1813 p => p%next
1814 ENDDO
1815 ELSE
1816 IF ( switch .EQ. boundary_only ) THEN
1817 CALL wrf_bdyin( fid , grid , config_flags , switch , ierr )
1818 ENDIF
1819 ENDIF
1821 #if (DA_CORE != 1)
1822 CALL wrf_tsin( grid , ierr )
1823 #if (EM_CORE == 1)
1824 if (config_flags%track_loc_in > 0 ) then
1825 call track_input( grid , ierr )
1826 end if
1827 #endif
1828 #endif
1830 WRITE(wrf_err_message,*)'input_wrf: end, fid = ',fid
1831 CALL wrf_debug( 300 , wrf_err_message )
1833 IF ( (switch .EQ. input_only) .and. (grid%id .EQ. 1) ) THEN
1834 grid%dtbc = 0.0
1835 ENDIF
1837 RETURN
1838 END SUBROUTINE input_wrf
1840 SUBROUTINE is_this_data_ok_to_use ( fid , yes_use_this_data )
1842 USE module_io
1844 IMPLICIT NONE
1846 INTEGER , INTENT(IN) :: fid
1847 LOGICAL , INTENT(OUT) :: yes_use_this_data
1849 ! Local vars
1851 CHARACTER (LEN=1024) :: input_title_char
1852 LOGICAL :: skip_rigorous_and_return_right_away
1853 INTEGER :: ierr
1855 ! Make sure that the input data is consistent with the current code.
1857 input_title_char = ' '
1858 CALL wrf_get_dom_ti_char ( fid , 'TITLE' , input_title_char , ierr )
1859 IF ( ierr .NE. 0 ) THEN
1860 WRITE(wrf_err_message,*)'Error trying to read metadata'
1861 CALL wrf_debug( 0 , wrf_err_message )
1862 yes_use_this_data = .FALSE.
1863 RETURN
1864 ELSE IF ( TRIM(input_title_char) .EQ. "" ) THEN
1865 WRITE(wrf_err_message,*)'The type of file is empty'
1866 CALL wrf_debug( 0 , wrf_err_message )
1867 yes_use_this_data = .FALSE.
1868 RETURN
1869 END IF
1871 ! There are some data sets that will be immune to the rigorous vetting.
1873 skip_rigorous_and_return_right_away = .FALSE.
1875 IF ( &
1876 ( INDEX(TRIM(input_title_char),'METGRID' ) .NE. 0 ) .OR. &
1877 ( INDEX(TRIM(input_title_char),'OBSGRID' ) .NE. 0 ) .OR. &
1878 ( INDEX(TRIM(input_title_char),'SFCFDDA' ) .NE. 0 ) .OR. &
1879 ( INDEX(TRIM(input_title_char),'EMISSIONS' ) .NE. 0 ) .OR. &
1880 ( INDEX(TRIM(input_title_char),'XYZZY' ) .NE. 0 ) &
1881 ) THEN
1882 WRITE(wrf_err_message,*)'Yes, this special data is acceptable to use: ' // TRIM(input_title_char)
1883 CALL wrf_debug( 0 , wrf_err_message )
1884 skip_rigorous_and_return_right_away = .TRUE.
1885 END IF
1887 ! Based on the file testing, do we return right away?
1889 IF ( skip_rigorous_and_return_right_away ) THEN
1890 yes_use_this_data = .TRUE.
1891 RETURN
1892 END IF
1894 IF ( INDEX(TRIM(input_title_char),' V4.' ) .NE. 0 ) THEN
1895 yes_use_this_data = .TRUE.
1896 ELSE
1897 WRITE(wrf_err_message,*)'This input data is not V4: ' // TRIM(input_title_char)
1898 CALL wrf_debug( 0 , wrf_err_message )
1899 yes_use_this_data = .FALSE.
1900 END IF
1902 END SUBROUTINE is_this_data_ok_to_use
1904 FUNCTION check_which_switch (switch) RESULT (aux_thing)
1905 IMPLICIT NONE
1906 INTEGER, INTENT(IN) :: switch
1907 CHARACTER(10) :: aux_thing
1909 CHARACTER(LEN=80) :: joe_message
1910 INTEGER :: switch_loop, start, end, count
1912 aux_thing = 'auxinputxx'
1914 start = MAX_HISTORY + 1
1915 end = 2*MAX_HISTORY
1916 count = 0
1917 DO switch_loop = start, end
1918 IF ( switch .EQ. switch_loop ) THEN
1919 IF ( count .EQ. 0 ) THEN
1920 WRITE(aux_thing,FMT='(a )') 'wrfinput '
1921 ELSE IF ( count .LT. 10 ) THEN
1922 WRITE(aux_thing,FMT='(a,i1 )') 'auxinput',count
1923 ELSE
1924 WRITE(aux_thing,FMT='(a,i2.2 )') 'auxinput',count
1925 END IF
1926 END IF
1927 count = count +1
1928 END DO
1929 END FUNCTION check_which_switch