ndown_em.F
References to this file elsewhere.
1 !WRF:DRIVER_LAYER:MAIN
2 !
3
4 PROGRAM ndown_em
5
6 USE module_machine
7 USE module_domain
8 USE module_initialize_real
9 USE module_integrate
10 USE module_driver_constants
11 USE module_configure
12 USE module_io_domain
13 USE module_utility
14
15 USE module_timing
16 USE module_wrf_error
17 #ifdef DM_PARALLEL
18 USE module_dm
19 #endif
20
21 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
22 !new for bc
23 USE module_bc
24 USE module_big_step_utilities_em
25 USE module_get_file_names
26 #ifdef WRF_CHEM
27 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
28 ! for chemistry
29 USE module_input_chem_data
30 ! USE module_input_chem_bioemiss
31 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
32 #endif
33
34 IMPLICIT NONE
35 ! interface
36 INTERFACE
37 ! mediation-supplied
38 SUBROUTINE med_read_wrf_chem_bioemiss ( grid , config_flags)
39 USE module_domain
40 TYPE (domain) grid
41 TYPE (grid_config_rec_type) config_flags
42 END SUBROUTINE med_read_wrf_chem_bioemiss
43
44 SUBROUTINE init_domain_constants_em_ptr ( parent , nest )
45 USE module_domain
46 USE module_configure
47 TYPE(domain), POINTER :: parent , nest
48 END SUBROUTINE init_domain_constants_em_ptr
49
50 END INTERFACE
51
52
53
54 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
55 !new for bc
56 INTEGER :: ids , ide , jds , jde , kds , kde
57 INTEGER :: ims , ime , jms , jme , kms , kme
58 INTEGER :: ips , ipe , jps , jpe , kps , kpe
59 INTEGER :: its , ite , jts , jte , kts , kte
60 INTEGER :: nids, nide, njds, njde, nkds, nkde, &
61 nims, nime, njms, njme, nkms, nkme, &
62 nips, nipe, njps, njpe, nkps, nkpe
63 INTEGER :: spec_bdy_width
64 INTEGER :: i , j , k , nvchem
65 INTEGER :: time_loop_max , time_loop
66 INTEGER :: total_time_sec , file_counter
67 INTEGER :: julyr , julday , iswater , map_proj
68 INTEGER :: icnt
69
70 REAL :: dt , new_bdy_frq
71 REAL :: gmt , cen_lat , cen_lon , dx , dy , truelat1 , truelat2 , moad_cen_lat , stand_lon
72
73 REAL , DIMENSION(:,:,:) , ALLOCATABLE :: ubdy3dtemp1 , vbdy3dtemp1 , tbdy3dtemp1 , pbdy3dtemp1 , qbdy3dtemp1
74 REAL , DIMENSION(:,:,:) , ALLOCATABLE :: mbdy2dtemp1
75 REAL , DIMENSION(:,:,:) , ALLOCATABLE :: ubdy3dtemp2 , vbdy3dtemp2 , tbdy3dtemp2 , pbdy3dtemp2 , qbdy3dtemp2
76 REAL , DIMENSION(:,:,:) , ALLOCATABLE :: mbdy2dtemp2
77 REAL , DIMENSION(:,:,:) , ALLOCATABLE :: cbdy3dtemp1 , cbdy3dtemp2
78 REAL , DIMENSION(:,:,:,:) , ALLOCATABLE :: cbdy3dtemp0
79
80 CHARACTER(LEN=19) :: start_date_char , current_date_char , end_date_char
81 CHARACTER(LEN=19) :: stopTimeStr
82
83 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
84
85 INTEGER :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat
86
87 REAL :: time
88 INTEGER :: rc
89
90 INTEGER :: loop , levels_to_process
91 INTEGER , PARAMETER :: max_sanity_file_loop = 100
92
93 TYPE (domain) , POINTER :: keep_grid, grid_ptr, null_domain, parent_grid , nested_grid
94 TYPE (domain) :: dummy
95 TYPE (grid_config_rec_type) :: config_flags
96 INTEGER :: number_at_same_level
97 INTEGER :: time_step_begin_restart
98
99 INTEGER :: max_dom , domain_id , fid , fido, fidb , oid , idum1 , idum2 , ierr
100 INTEGER :: status_next_var
101 INTEGER :: debug_level
102 LOGICAL :: input_from_file , need_new_file
103 CHARACTER (LEN=19) :: date_string
104
105 #ifdef DM_PARALLEL
106 INTEGER :: nbytes
107 INTEGER, PARAMETER :: configbuflen = 4* CONFIG_BUF_LEN
108 INTEGER :: configbuf( configbuflen )
109 LOGICAL , EXTERNAL :: wrf_dm_on_monitor
110 #endif
111
112 INTEGER :: idsi
113 CHARACTER (LEN=80) :: inpname , outname , bdyname
114 CHARACTER (LEN=80) :: si_inpname
115 character *19 :: temp19
116 character *24 :: temp24 , temp24b
117 character(len=24) :: start_date_hold
118
119 CHARACTER (LEN=80) :: message
120 integer :: ii
121
122 #include "version_decl"
123
124 ! Interface block for routine that passes pointers and needs to know that they
125 ! are receiving pointers.
126
127 INTERFACE
128
129 SUBROUTINE med_interp_domain ( parent_grid , nested_grid )
130 USE module_domain
131 USE module_configure
132 TYPE(domain), POINTER :: parent_grid , nested_grid
133 END SUBROUTINE med_interp_domain
134
135 SUBROUTINE Setup_Timekeeping( parent_grid )
136 USE module_domain
137 TYPE(domain), POINTER :: parent_grid
138 END SUBROUTINE Setup_Timekeeping
139
140 END INTERFACE
141
142 ! Define the name of this program (program_name defined in module_domain)
143
144 program_name = "NDOWN_EM " // TRIM(release_version) // " PREPROCESSOR"
145
146 #ifdef DM_PARALLEL
147 CALL disable_quilting
148 #endif
149
150 ! Initialize the modules used by the WRF system. Many of the CALLs made from the
151 ! init_modules routine are NO-OPs. Typical initializations are: the size of a
152 ! REAL, setting the file handles to a pre-use value, defining moisture and
153 ! chemistry indices, etc.
154
155 CALL init_modules(1) ! Phase 1 returns after MPI_INIT() (if it is called)
156 CALL WRFU_Initialize( defaultCalendar=WRFU_CAL_GREGORIAN, rc=rc )
157 CALL init_modules(2) ! Phase 2 resumes after MPI_INIT() (if it is called)
158
159 ! Get the NAMELIST data. This is handled in the initial_config routine. All of the
160 ! NAMELIST input variables are assigned to the model_config_rec structure. Below,
161 ! note for parallel processing, only the monitor processor handles the raw Fortran
162 ! I/O, and then broadcasts the info to each of the other nodes.
163
164 #ifdef DM_PARALLEL
165 IF ( wrf_dm_on_monitor() ) THEN
166 CALL initial_config
167 ENDIF
168 CALL get_config_as_buffer( configbuf, configbuflen, nbytes )
169 CALL wrf_dm_bcast_bytes( configbuf, nbytes )
170 CALL set_config_as_buffer( configbuf, configbuflen )
171 CALL wrf_dm_initialize
172 #else
173 CALL initial_config
174 #endif
175
176 ! And here is an instance of using the information in the NAMELIST.
177
178 CALL nl_get_debug_level ( 1, debug_level )
179 CALL set_wrf_debug_level ( debug_level )
180
181 ! Allocated and configure the mother domain. Since we are in the nesting down
182 ! mode, we know a) we got a nest, and b) we only got 1 nest.
183
184 NULLIFY( null_domain )
185
186 CALL wrf_message ( program_name )
187 CALL wrf_debug ( 100 , 'ndown_em: calling alloc_and_configure_domain coarse ' )
188 CALL alloc_and_configure_domain ( domain_id = 1 , &
189 grid = head_grid , &
190 parent = null_domain , &
191 kid = -1 )
192
193 parent_grid => head_grid
194
195 ! Set up time initializations.
196
197 CALL Setup_Timekeeping ( parent_grid )
198
199 CALL domain_clock_set( head_grid, &
200 time_step_seconds=model_config_rec%interval_seconds )
201 CALL wrf_debug ( 100 , 'ndown_em: calling model_to_grid_config_rec ' )
202 CALL model_to_grid_config_rec ( parent_grid%id , model_config_rec , config_flags )
203 CALL wrf_debug ( 100 , 'ndown_em: calling set_scalar_indices_from_config ' )
204 CALL set_scalar_indices_from_config ( parent_grid%id , idum1, idum2 )
205
206 ! Initialize the I/O for WRF.
207
208 CALL wrf_debug ( 100 , 'ndown_em: calling init_wrfio' )
209 CALL init_wrfio
210
211 ! Some of the configuration values may have been modified from the initial READ
212 ! of the NAMELIST, so we re-broadcast the configuration records.
213
214 #ifdef DM_PARALLEL
215 CALL get_config_as_buffer( configbuf, configbuflen, nbytes )
216 CALL wrf_dm_bcast_bytes( configbuf, nbytes )
217 CALL set_config_as_buffer( configbuf, configbuflen )
218 #endif
219
220 ! We need to current and starting dates for the output files. The times need to be incremented
221 ! so that the lateral BC files are not overwritten.
222
223 WRITE ( start_date_char , FMT = '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) &
224 model_config_rec%start_year (parent_grid%id) , &
225 model_config_rec%start_month (parent_grid%id) , &
226 model_config_rec%start_day (parent_grid%id) , &
227 model_config_rec%start_hour (parent_grid%id) , &
228 model_config_rec%start_minute(parent_grid%id) , &
229 model_config_rec%start_second(parent_grid%id)
230
231 WRITE ( end_date_char , FMT = '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) &
232 model_config_rec% end_year (parent_grid%id) , &
233 model_config_rec% end_month (parent_grid%id) , &
234 model_config_rec% end_day (parent_grid%id) , &
235 model_config_rec% end_hour (parent_grid%id) , &
236 model_config_rec% end_minute(parent_grid%id) , &
237 model_config_rec% end_second(parent_grid%id)
238
239 ! Override stop time with value computed above.
240 CALL domain_clock_set( parent_grid, stop_timestr=end_date_char )
241
242 CALL geth_idts ( end_date_char , start_date_char , total_time_sec )
243
244 new_bdy_frq = model_config_rec%interval_seconds
245 time_loop_max = total_time_sec / model_config_rec%interval_seconds + 1
246
247 start_date = start_date_char // '.0000'
248 current_date = start_date_char // '.0000'
249 start_date_hold = start_date_char // '.0000'
250 current_date_char = start_date_char
251
252 ! Get a list of available file names to try. This fills up the eligible_file_name
253 ! array with number_of_eligible_files entries. This routine issues a nonstandard
254 ! call (system).
255
256 file_counter = 1
257 need_new_file = .FALSE.
258 CALL unix_ls ( 'wrfout' , parent_grid%id )
259
260 ! Open the input data (wrfout_d01_xxxxxx) for reading.
261
262 CALL wrf_debug ( 100 , 'ndown_em main: calling open_r_dataset for ' // TRIM(eligible_file_name(file_counter)) )
263 CALL open_r_dataset ( fid, TRIM(eligible_file_name(file_counter)) , head_grid , config_flags , "DATASET=AUXINPUT1", ierr )
264 IF ( ierr .NE. 0 ) THEN
265 WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'program ndown: error opening ',TRIM(eligible_file_name(file_counter)), &
266 ' for reading ierr=',ierr
267 CALL WRF_ERROR_FATAL ( wrf_err_message )
268 ENDIF
269
270 ! We know how many time periods to process, so we begin.
271
272 big_time_loop_thingy : DO time_loop = 1 , time_loop_max
273
274 ! Which date are we currently soliciting?
275
276 CALL geth_newdate ( date_string , start_date_char , ( time_loop - 1 ) * NINT ( new_bdy_frq) )
277 print *,'-------->>> Processing data: loop=',time_loop,' date/time = ',date_string
278 current_date_char = date_string
279 current_date = date_string // '.0000'
280 start_date = date_string // '.0000'
281 print *,'loopmax = ', time_loop_max, ' ending date = ',end_date_char
282 CALL domain_clock_set( parent_grid, &
283 current_timestr=current_date(1:19) )
284
285 ! Which times are in this file, and more importantly, are any of them the
286 ! ones that we want? We need to loop over times in each files, loop
287 ! over files.
288
289 get_the_right_time : DO
290
291 CALL wrf_get_next_time ( fid , date_string , status_next_var )
292 print *,'file date/time = ',date_string,' desired date = ',current_date_char,' status = ', status_next_var
293
294 IF ( status_next_var .NE. 0 ) THEN
295 CALL wrf_debug ( 100 , 'ndown_em main: calling close_dataset for ' // TRIM(eligible_file_name(file_counter)) )
296 CALL close_dataset ( fid , config_flags , "DATASET=INPUT" )
297 file_counter = file_counter + 1
298 IF ( file_counter .GT. number_of_eligible_files ) THEN
299 WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'program ndown: opening too many files'
300 CALL WRF_ERROR_FATAL ( wrf_err_message )
301 END IF
302 CALL wrf_debug ( 100 , 'ndown_em main: calling open_r_dataset for ' // TRIM(eligible_file_name(file_counter)) )
303 CALL open_r_dataset ( fid, TRIM(eligible_file_name(file_counter)) , head_grid , config_flags , "DATASET=INPUT", ierr )
304 IF ( ierr .NE. 0 ) THEN
305 WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'program ndown: error opening ',TRIM(eligible_file_name(file_counter)), &
306 ' for reading ierr=',ierr
307 CALL WRF_ERROR_FATAL ( wrf_err_message )
308 ENDIF
309 CYCLE get_the_right_time
310 ELSE IF ( TRIM(date_string) .LT. TRIM(current_date_char) ) THEN
311 CYCLE get_the_right_time
312 ELSE IF ( TRIM(date_string) .EQ. TRIM(current_date_char) ) THEN
313 EXIT get_the_right_time
314 ELSE IF ( TRIM(date_string) .GT. TRIM(current_date_char) ) THEN
315 WRITE( wrf_err_message , FMT='(A,A,A,A,A)' ) 'Found ',TRIM(date_string),' before I found ',TRIM(current_date_char),'.'
316 CALL WRF_ERROR_FATAL ( wrf_err_message )
317 END IF
318 END DO get_the_right_time
319
320 CALL wrf_debug ( 100 , 'wrf: calling input_history' )
321 CALL wrf_get_previous_time ( fid , date_string , status_next_var )
322 CALL input_history ( fid , head_grid , config_flags, ierr )
323 CALL wrf_debug ( 100 , 'wrf: back from input_history' )
324
325 ! Get the coarse grid info for later transfer to the fine grid domain.
326
327 CALL wrf_get_dom_ti_integer ( fid , 'MAP_PROJ' , map_proj , 1 , icnt , ierr )
328 CALL wrf_get_dom_ti_real ( fid , 'DX' , dx , 1 , icnt , ierr )
329 CALL wrf_get_dom_ti_real ( fid , 'DY' , dy , 1 , icnt , ierr )
330 CALL wrf_get_dom_ti_real ( fid , 'CEN_LAT' , cen_lat , 1 , icnt , ierr )
331 CALL wrf_get_dom_ti_real ( fid , 'CEN_LON' , cen_lon , 1 , icnt , ierr )
332 CALL wrf_get_dom_ti_real ( fid , 'TRUELAT1' , truelat1 , 1 , icnt , ierr )
333 CALL wrf_get_dom_ti_real ( fid , 'TRUELAT2' , truelat2 , 1 , icnt , ierr )
334 CALL wrf_get_dom_ti_real ( fid , 'MOAD_CEN_LAT' , moad_cen_lat , 1 , icnt , ierr )
335 CALL wrf_get_dom_ti_real ( fid , 'STAND_LON' , stand_lon , 1 , icnt , ierr )
336 ! CALL wrf_get_dom_ti_real ( fid , 'GMT' , gmt , 1 , icnt , ierr )
337 ! CALL wrf_get_dom_ti_integer ( fid , 'JULYR' , julyr , 1 , icnt , ierr )
338 ! CALL wrf_get_dom_ti_integer ( fid , 'JULDAY' , julday , 1 , icnt , ierr )
339 CALL wrf_get_dom_ti_integer ( fid , 'ISWATER' , iswater , 1 , icnt , ierr )
340
341 ! First time in, do this: allocate sapce for the fine grid, get the config flags, open the
342 ! wrfinput and wrfbdy files. This COULD be done outside the time loop, I think, so check it
343 ! out and move it up if you can.
344
345 IF ( time_loop .EQ. 1 ) THEN
346
347 CALL wrf_message ( program_name )
348 CALL wrf_debug ( 100 , 'wrf: calling alloc_and_configure_domain fine ' )
349 CALL alloc_and_configure_domain ( domain_id = 2 , &
350 grid = nested_grid , &
351 parent = parent_grid , &
352 kid = 1 )
353
354 CALL wrf_debug ( 100 , 'wrf: calling model_to_grid_config_rec ' )
355 CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags )
356 CALL wrf_debug ( 100 , 'wrf: calling set_scalar_indices_from_config ' )
357 CALL set_scalar_indices_from_config ( nested_grid%id , idum1, idum2 )
358
359 ! Set up time initializations for the fine grid.
360
361 CALL Setup_Timekeeping ( nested_grid )
362 ! Strictly speaking, nest stop time should come from model_config_rec...
363 CALL domain_clock_get( parent_grid, stop_timestr=stopTimeStr )
364 CALL domain_clock_set( nested_grid, &
365 current_timestr=current_date(1:19), &
366 stop_timestr=stopTimeStr , &
367 time_step_seconds= &
368 model_config_rec%interval_seconds )
369
370 ! Generate an output file from this program, which will be an input file to WRF.
371
372 CALL nl_set_bdyfrq ( nested_grid%id , new_bdy_frq )
373 config_flags%bdyfrq = new_bdy_frq
374
375 #ifdef WRF_CHEM
376 nested_grid%chem_opt = parent_grid%chem_opt
377 nested_grid%chem_in_opt = parent_grid%chem_in_opt
378 #endif
379
380 ! Initialize constants and 1d arrays in fine grid from the parent.
381
382 CALL init_domain_constants_em_ptr ( parent_grid , nested_grid )
383
384 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
385
386 CALL wrf_debug ( 100 , 'ndown_em main: calling open_w_dataset for wrfinput' )
387 CALL construct_filename1( outname , 'wrfinput' , nested_grid%id , 2 )
388 CALL open_w_dataset ( fido, TRIM(outname) , nested_grid , config_flags , output_model_input , "DATASET=INPUT", ierr )
389 IF ( ierr .NE. 0 ) THEN
390 WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'program ndown: error opening ',TRIM(outname),' for reading ierr=',ierr
391 CALL WRF_ERROR_FATAL ( wrf_err_message )
392 ENDIF
393
394 ! Various sizes that we need to be concerned about.
395
396 ids = nested_grid%sd31
397 ide = nested_grid%ed31
398 kds = nested_grid%sd32
399 kde = nested_grid%ed32
400 jds = nested_grid%sd33
401 jde = nested_grid%ed33
402
403 ims = nested_grid%sm31
404 ime = nested_grid%em31
405 kms = nested_grid%sm32
406 kme = nested_grid%em32
407 jms = nested_grid%sm33
408 jme = nested_grid%em33
409
410 ips = nested_grid%sp31
411 ipe = nested_grid%ep31
412 kps = nested_grid%sp32
413 kpe = nested_grid%ep32
414 jps = nested_grid%sp33
415 jpe = nested_grid%ep33
416
417
418 print *, ids , ide , jds , jde , kds , kde
419 print *, ims , ime , jms , jme , kms , kme
420 print *, ips , ipe , jps , jpe , kps , kpe
421
422 spec_bdy_width = model_config_rec%spec_bdy_width
423 print *,'spec_bdy_width=',spec_bdy_width
424
425 ! This is the space needed to save the current 3d data for use in computing
426 ! the lateral boundary tendencies.
427
428 ALLOCATE ( ubdy3dtemp1(ims:ime,kms:kme,jms:jme) )
429 ALLOCATE ( vbdy3dtemp1(ims:ime,kms:kme,jms:jme) )
430 ALLOCATE ( tbdy3dtemp1(ims:ime,kms:kme,jms:jme) )
431 ALLOCATE ( pbdy3dtemp1(ims:ime,kms:kme,jms:jme) )
432 ALLOCATE ( qbdy3dtemp1(ims:ime,kms:kme,jms:jme) )
433 ALLOCATE ( mbdy2dtemp1(ims:ime,1:1, jms:jme) )
434 ALLOCATE ( ubdy3dtemp2(ims:ime,kms:kme,jms:jme) )
435 ALLOCATE ( vbdy3dtemp2(ims:ime,kms:kme,jms:jme) )
436 ALLOCATE ( tbdy3dtemp2(ims:ime,kms:kme,jms:jme) )
437 ALLOCATE ( pbdy3dtemp2(ims:ime,kms:kme,jms:jme) )
438 ALLOCATE ( qbdy3dtemp2(ims:ime,kms:kme,jms:jme) )
439 ALLOCATE ( mbdy2dtemp2(ims:ime,1:1, jms:jme) )
440 ALLOCATE ( cbdy3dtemp0(ims:ime,kms:kme,jms:jme,1:num_chem) )
441 ALLOCATE ( cbdy3dtemp1(ims:ime,kms:kme,jms:jme) )
442 ALLOCATE ( cbdy3dtemp2(ims:ime,kms:kme,jms:jme) )
443
444 END IF
445
446 CALL domain_clock_set( nested_grid, &
447 current_timestr=current_date(1:19), &
448 time_step_seconds= &
449 model_config_rec%interval_seconds )
450
451 ! Do the horizontal interpolation.
452
453 nested_grid%imask_nostag = 1
454 nested_grid%imask_xstag = 1
455 nested_grid%imask_ystag = 1
456 nested_grid%imask_xystag = 1
457
458 CALL med_interp_domain ( head_grid , nested_grid )
459 nested_grid%ht_int = nested_grid%ht
460
461 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
462
463 IF ( time_loop .EQ. 1 ) THEN
464
465 ! Dimension info for fine grid.
466
467 CALL get_ijk_from_grid ( nested_grid , &
468 nids, nide, njds, njde, nkds, nkde, &
469 nims, nime, njms, njme, nkms, nkme, &
470 nips, nipe, njps, njpe, nkps, nkpe )
471
472 ! Store horizontally interpolated terrain in temp location
473
474 CALL store_terrain ( nested_grid%ht_fine , nested_grid%ht , &
475 nids , nide , njds , njde , 1 , 1 , &
476 nims , nime , njms , njme , 1 , 1 , &
477 nips , nipe , njps , njpe , 1 , 1 )
478
479 ! Open the fine grid SI static file.
480
481 CALL construct_filename1( si_inpname , 'wrfndi' , nested_grid%id , 2 )
482 CALL wrf_debug ( 100 , 'med_sidata_input: calling open_r_dataset for ' // TRIM(si_inpname) )
483 CALL open_r_dataset ( idsi, TRIM(si_inpname) , nested_grid , config_flags , "DATASET=INPUT", ierr )
484 IF ( ierr .NE. 0 ) THEN
485 CALL wrf_error_fatal( 'real: error opening FG input for reading: ' // TRIM (si_inpname) )
486 END IF
487
488 ! Input data.
489
490 CALL wrf_debug ( 100 , 'ndown_em: calling input_aux_model_input2' )
491 CALL input_aux_model_input2 ( idsi , nested_grid , config_flags , ierr )
492 nested_grid%ht_input = nested_grid%ht
493
494 ! Close this fine grid static input file.
495
496 CALL wrf_debug ( 100 , 'ndown_em: closing fine grid static input' )
497 CALL close_dataset ( idsi , config_flags , "DATASET=INPUT" )
498
499 ! Blend parent and nest field of terrain.
500
501 CALL blend_terrain ( nested_grid%ht_fine , nested_grid%ht , &
502 nids , nide , njds , njde , 1 , 1 , &
503 nims , nime , njms , njme , 1 , 1 , &
504 nips , nipe , njps , njpe , 1 , 1 )
505
506 nested_grid%ht_input = nested_grid%ht
507 nested_grid%ht_int = nested_grid%ht_fine
508
509 ! We need a fine grid landuse in the interpolation. So we need to generate
510 ! that field now.
511
512 IF ( ( nested_grid%ivgtyp(ips,jps) .GT. 0 ) .AND. &
513 ( nested_grid%isltyp(ips,jps) .GT. 0 ) ) THEN
514 DO j = jps, MIN(jde-1,jpe)
515 DO i = ips, MIN(ide-1,ipe)
516 nested_grid% vegcat(i,j) = nested_grid%ivgtyp(i,j)
517 nested_grid%soilcat(i,j) = nested_grid%isltyp(i,j)
518 END DO
519 END DO
520
521 ELSE IF ( ( nested_grid% vegcat(ips,jps) .GT. 0.5 ) .AND. &
522 ( nested_grid%soilcat(ips,jps) .GT. 0.5 ) ) THEN
523 DO j = jps, MIN(jde-1,jpe)
524 DO i = ips, MIN(ide-1,ipe)
525 nested_grid%ivgtyp(i,j) = NINT(nested_grid% vegcat(i,j))
526 nested_grid%isltyp(i,j) = NINT(nested_grid%soilcat(i,j))
527 END DO
528 END DO
529
530 ELSE
531 num_veg_cat = SIZE ( nested_grid%landusef , DIM=2 )
532 num_soil_top_cat = SIZE ( nested_grid%soilctop , DIM=2 )
533 num_soil_bot_cat = SIZE ( nested_grid%soilcbot , DIM=2 )
534
535 CALL land_percentages ( nested_grid%xland , &
536 nested_grid%landusef , nested_grid%soilctop , nested_grid%soilcbot , &
537 nested_grid%isltyp , nested_grid%ivgtyp , &
538 num_veg_cat , num_soil_top_cat , num_soil_bot_cat , &
539 ids , ide , jds , jde , kds , kde , &
540 ims , ime , jms , jme , kms , kme , &
541 ips , ipe , jps , jpe , kps , kpe , &
542 model_config_rec%iswater(nested_grid%id) )
543
544 END IF
545
546 DO j = jps, MIN(jde-1,jpe)
547 DO i = ips, MIN(ide-1,ipe)
548 nested_grid%lu_index(i,j) = nested_grid%ivgtyp(i,j)
549 END DO
550 END DO
551
552 CALL check_consistency ( nested_grid%ivgtyp , nested_grid%isltyp , nested_grid%landmask , &
553 ids , ide , jds , jde , kds , kde , &
554 ims , ime , jms , jme , kms , kme , &
555 ips , ipe , jps , jpe , kps , kpe , &
556 model_config_rec%iswater(nested_grid%id) )
557
558 CALL check_consistency2( nested_grid%ivgtyp , nested_grid%isltyp , nested_grid%landmask , &
559 nested_grid%tmn , nested_grid%tsk , nested_grid%sst , nested_grid%xland , &
560 nested_grid%tslb , nested_grid%smois , nested_grid%sh2o , &
561 config_flags%num_soil_layers , nested_grid%id , &
562 ids , ide , jds , jde , kds , kde , &
563 ims , ime , jms , jme , kms , kme , &
564 ips , ipe , jps , jpe , kps , kpe , &
565 model_config_rec%iswater(nested_grid%id) )
566
567 END IF
568
569 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
570
571 ! We have 2 terrain elevations. One is from input and the other is from the
572 ! the horizontal interpolation.
573
574 nested_grid%ht_fine = nested_grid%ht_input
575 nested_grid%ht = nested_grid%ht_int
576
577 ! We have both the interpolated fields and the higher-resolution static fields. From these
578 ! the rebalancing is now done. Note also that the field nested_grid%ht is now from the
579 ! fine grid input file (after this call is completed).
580
581 CALL rebalance_driver ( nested_grid )
582
583 ! Different things happen during the different time loops:
584 ! first loop - write wrfinput file, close data set, copy files to holder arrays
585 ! middle loops - diff 3d/2d arrays, compute and output bc
586 ! last loop - diff 3d/2d arrays, compute and output bc, write wrfbdy file, close wrfbdy file
587
588 IF ( time_loop .EQ. 1 ) THEN
589
590 ! Set the time info.
591
592 print *,'current_date = ',current_date
593 CALL domain_clock_set( nested_grid, &
594 current_timestr=current_date(1:19) )
595 #ifdef WRF_CHEM
596 !
597 ! SEP Put in chemistry data
598 !
599 IF( nested_grid%chem_opt .NE. 0 ) then
600 ! IF( nested_grid%chem_in_opt .EQ. 0 ) then
601 ! Read the chemistry data from a previous wrf forecast (wrfout file)
602 ! Generate chemistry data from a idealized vertical profile
603 ! message = 'STARTING WITH BACKGROUND CHEMISTRY '
604 CALL wrf_message ( message )
605
606 ! CALL input_chem_profile ( nested_grid )
607
608 if( nested_grid%bio_emiss_opt .eq. 2 )then
609 message = 'READING BEIS3.11 EMISSIONS DATA'
610 CALL wrf_message ( message )
611 CALL med_read_wrf_chem_bioemiss ( nested_grid , config_flags)
612 endif
613 ! ELSE
614 ! message = 'RUNNING WITHOUT CHEMISTRY INITIALIZATION'
615 ! CALL wrf_message ( message )
616 ! ENDIF
617 ENDIF
618 #endif
619
620 ! Output the first time period of the data.
621
622 CALL output_model_input ( fido , nested_grid , config_flags , ierr )
623
624 CALL wrf_put_dom_ti_integer ( fido , 'MAP_PROJ' , map_proj , 1 , ierr )
625 ! CALL wrf_put_dom_ti_real ( fido , 'DX' , dx , 1 , ierr )
626 ! CALL wrf_put_dom_ti_real ( fido , 'DY' , dy , 1 , ierr )
627 CALL wrf_put_dom_ti_real ( fido , 'CEN_LAT' , cen_lat , 1 , ierr )
628 CALL wrf_put_dom_ti_real ( fido , 'CEN_LON' , cen_lon , 1 , ierr )
629 CALL wrf_put_dom_ti_real ( fido , 'TRUELAT1' , truelat1 , 1 , ierr )
630 CALL wrf_put_dom_ti_real ( fido , 'TRUELAT2' , truelat2 , 1 , ierr )
631 CALL wrf_put_dom_ti_real ( fido , 'MOAD_CEN_LAT' , moad_cen_lat , 1 , ierr )
632 CALL wrf_put_dom_ti_real ( fido , 'STAND_LON' , stand_lon , 1 , ierr )
633 CALL wrf_put_dom_ti_integer ( fido , 'ISWATER' , iswater , 1 , ierr )
634
635 ! These change if the initial time for the nest is not the same as the
636 ! first time period in the WRF output file.
637 ! Now that we know the starting date, we need to set the GMT, JULYR, and JULDAY
638 ! values for the global attributes. This call is based on the setting of the
639 ! current_date string.
640
641 CALL geth_julgmt ( julyr , julday , gmt)
642 CALL nl_set_julyr ( nested_grid%id , julyr )
643 CALL nl_set_julday ( nested_grid%id , julday )
644 CALL nl_set_gmt ( nested_grid%id , gmt )
645 CALL wrf_put_dom_ti_real ( fido , 'GMT' , gmt , 1 , ierr )
646 CALL wrf_put_dom_ti_integer ( fido , 'JULYR' , julyr , 1 , ierr )
647 CALL wrf_put_dom_ti_integer ( fido , 'JULDAY' , julday , 1 , ierr )
648 print *,'current_date =',current_date
649 print *,'julyr=',julyr
650 print *,'julday=',julday
651 print *,'gmt=',gmt
652
653 ! Close the input (wrfout_d01_000000, for example) file. That's right, the
654 ! input is an output file. Who'd've thunk.
655
656 CALL close_dataset ( fido , config_flags , "DATASET=INPUT" )
657
658 ! We need to save the 3d/2d data to compute a difference during the next loop. Couple the
659 ! 3d fields with total mu (mub + mu_2) and the stagger-specific map scale factor.
660
661 CALL couple ( nested_grid%em_mu_2 , nested_grid%em_mub , ubdy3dtemp1 , nested_grid%em_u_2 , &
662 'u' , nested_grid%msfu , &
663 ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
664 CALL couple ( nested_grid%em_mu_2 , nested_grid%em_mub , vbdy3dtemp1 , nested_grid%em_v_2 , &
665 'v' , nested_grid%msfv , &
666 ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
667 CALL couple ( nested_grid%em_mu_2 , nested_grid%em_mub , tbdy3dtemp1 , nested_grid%em_t_2 , &
668 't' , nested_grid%msft , &
669 ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
670 CALL couple ( nested_grid%em_mu_2 , nested_grid%em_mub , pbdy3dtemp1 , nested_grid%em_ph_2 , &
671 'h' , nested_grid%msft , &
672 ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
673 CALL couple ( nested_grid%em_mu_2 , nested_grid%em_mub , qbdy3dtemp1 , nested_grid%moist(:,:,:,P_QV) , &
674 't' , nested_grid%msft , &
675 ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
676
677 DO j = jps , jpe
678 DO i = ips , ipe
679 mbdy2dtemp1(i,1,j) = nested_grid%em_mu_2(i,j)
680 END DO
681 END DO
682
683 ! There are 2 components to the lateral boundaries. First, there is the starting
684 ! point of this time period - just the outer few rows and columns.
685
686 CALL stuff_bdy ( ubdy3dtemp1 , nested_grid%em_u_bxs, nested_grid%em_u_bxe, &
687 nested_grid%em_u_bys, nested_grid%em_u_bye, &
688 'U' , spec_bdy_width , &
689 ids , ide , jds , jde , kds , kde , &
690 ims , ime , jms , jme , kms , kme , &
691 ips , ipe , jps , jpe , kps , kpe )
692 CALL stuff_bdy ( vbdy3dtemp1 , nested_grid%em_v_bxs, nested_grid%em_v_bxe, &
693 nested_grid%em_v_bys, nested_grid%em_v_bye, &
694 'V' , spec_bdy_width , &
695 ids , ide , jds , jde , kds , kde , &
696 ims , ime , jms , jme , kms , kme , &
697 ips , ipe , jps , jpe , kps , kpe )
698 CALL stuff_bdy ( tbdy3dtemp1 , nested_grid%em_t_bxs, nested_grid%em_t_bxe, &
699 nested_grid%em_t_bys, nested_grid%em_t_bye, &
700 'T' , spec_bdy_width , &
701 ids , ide , jds , jde , kds , kde , &
702 ims , ime , jms , jme , kms , kme , &
703 ips , ipe , jps , jpe , kps , kpe )
704 CALL stuff_bdy ( pbdy3dtemp1 , nested_grid%em_ph_bxs, nested_grid%em_ph_bxe, &
705 nested_grid%em_ph_bys, nested_grid%em_ph_bye, &
706 'W' , spec_bdy_width , &
707 ids , ide , jds , jde , kds , kde , &
708 ims , ime , jms , jme , kms , kme , &
709 ips , ipe , jps , jpe , kps , kpe )
710 CALL stuff_bdy ( qbdy3dtemp1 , nested_grid%moist_bxs(:,:,:,P_QV), nested_grid%moist_bxe(:,:,:,P_QV), &
711 nested_grid%moist_bys(:,:,:,P_QV), nested_grid%moist_bye(:,:,:,P_QV), &
712 'T' , spec_bdy_width , &
713 ids , ide , jds , jde , kds , kde , &
714 ims , ime , jms , jme , kms , kme , &
715 ips , ipe , jps , jpe , kps , kpe )
716 CALL stuff_bdy ( mbdy2dtemp1 , nested_grid%em_mu_bxs, nested_grid%em_mu_bxe, &
717 nested_grid%em_mu_bys, nested_grid%em_mu_bye, &
718 'M' , spec_bdy_width , &
719 ids , ide , jds , jde , 1 , 1 , &
720 ims , ime , jms , jme , 1 , 1 , &
721 ips , ipe , jps , jpe , 1 , 1 )
722 #ifdef WRF_CHEM
723 do nvchem=1,num_chem
724 ! if(nvchem.eq.p_o3)then
725 ! write(0,*)'fill ch_b',cbdy3dtemp1(5,1,5),nvchem
726 ! endif
727 cbdy3dtemp1(ips:ipe,kps:kpe,jps:jpe)=nested_grid%chem(ips:ipe,kps:kpe,jps:jpe,nvchem)
728 ! if(nvchem.eq.p_o3)then
729 ! write(0,*)'fill ch_b',cbdy3dtemp1(5,1,5)
730 ! endif
731 CALL stuff_bdy ( cbdy3dtemp1 , nested_grid%chem_bxs(:,:,:,nvchem), &
732 nested_grid%chem_bxe(:,:,:,nvchem), &
733 nested_grid%chem_bys(:,:,:,nvchem), &
734 nested_grid%chem_bye(:,:,:,nvchem), &
735 'T' , spec_bdy_width , &
736 ids , ide , jds , jde , kds , kde , &
737 ims , ime , jms , jme , kms , kme , &
738 ips , ipe , jps , jpe , kps , kpe )
739 cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem)=cbdy3dtemp1(ips:ipe,kps:kpe,jps:jpe)
740 ! if(nvchem.eq.p_o3)then
741 ! write(0,*)'filled ch_b',time_loop,cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem)
742 ! endif
743 enddo
744 #endif
745 ELSE IF ( ( time_loop .GT. 1 ) .AND. ( time_loop .LT. time_loop_max ) ) THEN
746
747 CALL couple ( nested_grid%em_mu_2 , nested_grid%em_mub , ubdy3dtemp2 , nested_grid%em_u_2 , &
748 'u' , nested_grid%msfu , &
749 ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
750 CALL couple ( nested_grid%em_mu_2 , nested_grid%em_mub , vbdy3dtemp2 , nested_grid%em_v_2 , &
751 'v' , nested_grid%msfv , &
752 ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
753 CALL couple ( nested_grid%em_mu_2 , nested_grid%em_mub , tbdy3dtemp2 , nested_grid%em_t_2 , &
754 't' , nested_grid%msft , &
755 ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
756 CALL couple ( nested_grid%em_mu_2 , nested_grid%em_mub , pbdy3dtemp2 , nested_grid%em_ph_2 , &
757 'h' , nested_grid%msft , &
758 ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
759 CALL couple ( nested_grid%em_mu_2 , nested_grid%em_mub , qbdy3dtemp2 , nested_grid%moist(:,:,:,P_QV) , &
760 't' , nested_grid%msft , &
761 ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
762
763 DO j = jps , jpe
764 DO i = ips , ipe
765 mbdy2dtemp2(i,1,j) = nested_grid%em_mu_2(i,j)
766 END DO
767 END DO
768
769 ! During all of the loops after the first loop, we first compute the boundary
770 ! tendencies with the current data values and the previously save information
771 ! stored in the *bdy3dtemp1 arrays.
772
773 CALL stuff_bdytend ( ubdy3dtemp2 , ubdy3dtemp1 , new_bdy_frq , &
774 nested_grid%em_u_btxs, nested_grid%em_u_btxe , &
775 nested_grid%em_u_btys, nested_grid%em_u_btye , &
776 'U' , &
777 spec_bdy_width , &
778 ids , ide , jds , jde , kds , kde , &
779 ims , ime , jms , jme , kms , kme , &
780 ips , ipe , jps , jpe , kps , kpe )
781 CALL stuff_bdytend ( vbdy3dtemp2 , vbdy3dtemp1 , new_bdy_frq , &
782 nested_grid%em_v_btxs, nested_grid%em_v_btxe , &
783 nested_grid%em_v_btys, nested_grid%em_v_btye , &
784 'V' , &
785 spec_bdy_width , &
786 ids , ide , jds , jde , kds , kde , &
787 ims , ime , jms , jme , kms , kme , &
788 ips , ipe , jps , jpe , kps , kpe )
789 CALL stuff_bdytend ( tbdy3dtemp2 , tbdy3dtemp1 , new_bdy_frq , &
790 nested_grid%em_t_btxs, nested_grid%em_t_btxe , &
791 nested_grid%em_t_btys, nested_grid%em_t_btye , &
792 'T' , &
793 spec_bdy_width , &
794 ids , ide , jds , jde , kds , kde , &
795 ims , ime , jms , jme , kms , kme , &
796 ips , ipe , jps , jpe , kps , kpe )
797 CALL stuff_bdytend ( pbdy3dtemp2 , pbdy3dtemp1 , new_bdy_frq , &
798 nested_grid%em_ph_btxs, nested_grid%em_ph_btxe , &
799 nested_grid%em_ph_btys, nested_grid%em_ph_btye , &
800 'W' , &
801 spec_bdy_width , &
802 ids , ide , jds , jde , kds , kde , &
803 ims , ime , jms , jme , kms , kme , &
804 ips , ipe , jps , jpe , kps , kpe )
805 CALL stuff_bdytend ( qbdy3dtemp2 , qbdy3dtemp1 , new_bdy_frq , &
806 nested_grid%moist_btxs(:,:,:,P_QV), nested_grid%moist_btxe(:,:,:,P_QV), &
807 nested_grid%moist_btys(:,:,:,P_QV), nested_grid%moist_btye(:,:,:,P_QV), &
808 'T' , &
809 spec_bdy_width , &
810 ids , ide , jds , jde , kds , kde , &
811 ims , ime , jms , jme , kms , kme , &
812 ips , ipe , jps , jpe , kps , kpe )
813 CALL stuff_bdytend ( mbdy2dtemp2 , mbdy2dtemp1 , new_bdy_frq , &
814 nested_grid%em_mu_btxs, nested_grid%em_mu_btxe , &
815 nested_grid%em_mu_btys, nested_grid%em_mu_btye , &
816 'M' , &
817 spec_bdy_width , &
818 ids , ide , jds , jde , 1 , 1 , &
819 ims , ime , jms , jme , 1 , 1 , &
820 ips , ipe , jps , jpe , 1 , 1 )
821 #ifdef WRF_CHEM
822 do nvchem=1,num_chem
823 cbdy3dtemp1(ips:ipe,kps:kpe,jps:jpe)=cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem)
824 cbdy3dtemp2(ips:ipe,kps:kpe,jps:jpe)=nested_grid%chem(ips:ipe,kps:kpe,jps:jpe,nvchem)
825 ! if(nvchem.eq.p_o3)then
826 ! write(0,*)'fill 1ch_b2',time_loop,cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem),cbdy3dtemp2(ips,kps,jps)
827 ! endif
828 CALL stuff_bdytend ( cbdy3dtemp2 , cbdy3dtemp1 , new_bdy_frq , &
829 nested_grid%chem_btxs(:,:,:,nvchem), nested_grid%chem_btxe(:,:,:,nvchem), &
830 nested_grid%chem_btys(:,:,:,nvchem), nested_grid%chem_btye(:,:,:,nvchem), &
831 'T' , &
832 spec_bdy_width , &
833 ids , ide , jds , jde , kds , kde , &
834 ims , ime , jms , jme , kms , kme , &
835 ips , ipe , jps , jpe , kps , kpe )
836 cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem)=cbdy3dtemp2(ips:ipe,kps:kpe,jps:jpe)
837 ! if(nvchem.eq.p_o3)then
838 ! write(0,*)'fill 2ch_b2',cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem),cbdy3dtemp2(ips,kps,jps)
839 ! endif
840 enddo
841 #endif
842 IF ( time_loop .EQ. 2 ) THEN
843
844 ! Generate an output file from this program, which will be an input file to WRF.
845
846 CALL wrf_debug ( 100 , 'ndown_em main: calling open_w_dataset for wrfbdy' )
847 CALL construct_filename1( bdyname , 'wrfbdy' , nested_grid%id , 2 )
848 CALL open_w_dataset ( fidb, TRIM(bdyname) , nested_grid , config_flags , output_boundary , &
849 "DATASET=BOUNDARY", ierr )
850 IF ( ierr .NE. 0 ) THEN
851 WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'program ndown: error opening ',TRIM(bdyname),' for reading ierr=',ierr
852 CALL WRF_ERROR_FATAL ( wrf_err_message )
853 ENDIF
854
855 END IF
856
857 ! Both pieces of the boundary data are now available to be written.
858
859 CALL domain_clock_set( nested_grid, &
860 current_timestr=current_date(1:19) )
861 temp24= current_date
862 temp24b=start_date_hold
863 start_date = start_date_hold
864 CALL geth_newdate ( temp19 , temp24b(1:19) , (time_loop-2) * model_config_rec%interval_seconds )
865 current_date = temp19 // '.0000'
866 CALL geth_julgmt ( julyr , julday , gmt)
867 CALL nl_set_julyr ( nested_grid%id , julyr )
868 CALL nl_set_julday ( nested_grid%id , julday )
869 CALL nl_set_gmt ( nested_grid%id , gmt )
870 CALL wrf_put_dom_ti_real ( fidb , 'GMT' , gmt , 1 , ierr )
871 CALL wrf_put_dom_ti_integer ( fidb , 'JULYR' , julyr , 1 , ierr )
872 CALL wrf_put_dom_ti_integer ( fidb , 'JULDAY' , julday , 1 , ierr )
873 CALL domain_clock_set( nested_grid, &
874 current_timestr=current_date(1:19) )
875 print *,'bdy time = ',time_loop-1,' bdy date = ',current_date,' ',start_date
876 CALL output_boundary ( fidb , nested_grid , config_flags , ierr )
877 current_date = temp24
878 start_date = temp24b
879 CALL domain_clock_set( nested_grid, &
880 current_timestr=current_date(1:19) )
881
882 IF ( time_loop .EQ. 2 ) THEN
883 CALL wrf_put_dom_ti_real ( fidb , 'BDYFRQ' , new_bdy_frq , 1 , ierr )
884 END IF
885
886 ! We need to save the 3d data to compute a difference during the next loop. Couple the
887 ! 3d fields with total mu (mub + mu_2) and the stagger-specific map scale factor.
888 ! We load up the boundary data again for use in the next loop.
889
890 DO j = jps , jpe
891 DO k = kps , kpe
892 DO i = ips , ipe
893 ubdy3dtemp1(i,k,j) = ubdy3dtemp2(i,k,j)
894 vbdy3dtemp1(i,k,j) = vbdy3dtemp2(i,k,j)
895 tbdy3dtemp1(i,k,j) = tbdy3dtemp2(i,k,j)
896 pbdy3dtemp1(i,k,j) = pbdy3dtemp2(i,k,j)
897 qbdy3dtemp1(i,k,j) = qbdy3dtemp2(i,k,j)
898 END DO
899 END DO
900 END DO
901
902 DO j = jps , jpe
903 DO i = ips , ipe
904 mbdy2dtemp1(i,1,j) = mbdy2dtemp2(i,1,j)
905 END DO
906 END DO
907
908 ! There are 2 components to the lateral boundaries. First, there is the starting
909 ! point of this time period - just the outer few rows and columns.
910
911 CALL stuff_bdy ( ubdy3dtemp1 , &
912 nested_grid%em_u_bxs, nested_grid%em_u_bxe , &
913 nested_grid%em_u_bys, nested_grid%em_u_bye , &
914 'U' , spec_bdy_width , &
915 ids , ide , jds , jde , kds , kde , &
916 ims , ime , jms , jme , kms , kme , &
917 ips , ipe , jps , jpe , kps , kpe )
918 CALL stuff_bdy ( vbdy3dtemp1 , &
919 nested_grid%em_v_bxs, nested_grid%em_v_bxe , &
920 nested_grid%em_v_bys, nested_grid%em_v_bye , &
921 'V' , spec_bdy_width , &
922 ids , ide , jds , jde , kds , kde , &
923 ims , ime , jms , jme , kms , kme , &
924 ips , ipe , jps , jpe , kps , kpe )
925 CALL stuff_bdy ( tbdy3dtemp1 , &
926 nested_grid%em_t_bxs, nested_grid%em_t_bxe , &
927 nested_grid%em_t_bys, nested_grid%em_t_bye , &
928 'T' , spec_bdy_width , &
929 ids , ide , jds , jde , kds , kde , &
930 ims , ime , jms , jme , kms , kme , &
931 ips , ipe , jps , jpe , kps , kpe )
932 CALL stuff_bdy ( pbdy3dtemp1 , &
933 nested_grid%em_ph_bxs, nested_grid%em_ph_bxe , &
934 nested_grid%em_ph_bys, nested_grid%em_ph_bye , &
935 'W' , spec_bdy_width , &
936 ids , ide , jds , jde , kds , kde , &
937 ims , ime , jms , jme , kms , kme , &
938 ips , ipe , jps , jpe , kps , kpe )
939 CALL stuff_bdy ( qbdy3dtemp1 , &
940 nested_grid%moist_bxs(:,:,:,P_QV), nested_grid%moist_bxe(:,:,:,P_QV), &
941 nested_grid%moist_bys(:,:,:,P_QV), nested_grid%moist_bye(:,:,:,P_QV), &
942 'T' , spec_bdy_width , &
943 ids , ide , jds , jde , kds , kde , &
944 ims , ime , jms , jme , kms , kme , &
945 ips , ipe , jps , jpe , kps , kpe )
946 #ifdef WRF_CHEM
947 do nvchem=1,num_chem
948 cbdy3dtemp1(ips:ipe,kps:kpe,jps:jpe)=cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem)
949 ! if(nvchem.eq.p_o3)then
950 ! write(0,*)'fill 2ch_b3',cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem)
951 ! endif
952 CALL stuff_bdy ( cbdy3dtemp1 , &
953 nested_grid%chem_bxs(:,:,:,nvchem), nested_grid%chem_bxe(:,:,:,nvchem), &
954 nested_grid%chem_bys(:,:,:,nvchem), nested_grid%chem_bye(:,:,:,nvchem), &
955 'T' , spec_bdy_width , &
956 ids , ide , jds , jde , kds , kde , &
957 ims , ime , jms , jme , kms , kme , &
958 ips , ipe , jps , jpe , kps , kpe )
959 ! cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem)=cbdy3dtemp1(ips:ipe,kps:kpe,jps:jpe)
960 ! if(nvchem.eq.p_o3)then
961 ! write(0,*)'fill 2ch_b3',cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem)
962 ! endif
963 enddo
964 #endif
965 CALL stuff_bdy ( mbdy2dtemp1 , &
966 nested_grid%em_mu_bxs, nested_grid%em_mu_bxe , &
967 nested_grid%em_mu_bys, nested_grid%em_mu_bye , &
968 'M' , spec_bdy_width , &
969 ids , ide , jds , jde , 1 , 1 , &
970 ims , ime , jms , jme , 1 , 1 , &
971 ips , ipe , jps , jpe , 1 , 1 )
972
973 ELSE IF ( time_loop .EQ. time_loop_max ) THEN
974
975 CALL couple ( nested_grid%em_mu_2 , nested_grid%em_mub , ubdy3dtemp2 , nested_grid%em_u_2 , &
976 'u' , nested_grid%msfu , &
977 ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
978 CALL couple ( nested_grid%em_mu_2 , nested_grid%em_mub , vbdy3dtemp2 , nested_grid%em_v_2 , &
979 'v' , nested_grid%msfv , &
980 ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
981 CALL couple ( nested_grid%em_mu_2 , nested_grid%em_mub , tbdy3dtemp2 , nested_grid%em_t_2 , &
982 't' , nested_grid%msft , &
983 ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
984 CALL couple ( nested_grid%em_mu_2 , nested_grid%em_mub , pbdy3dtemp2 , nested_grid%em_ph_2 , &
985 'h' , nested_grid%msft , &
986 ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
987 CALL couple ( nested_grid%em_mu_2 , nested_grid%em_mub , qbdy3dtemp2 , nested_grid%moist(:,:,:,P_QV) , &
988 't' , nested_grid%msft , &
989 ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
990 mbdy2dtemp2(:,1,:) = nested_grid%em_mu_2(:,:)
991
992 ! During all of the loops after the first loop, we first compute the boundary
993 ! tendencies with the current data values and the previously save information
994 ! stored in the *bdy3dtemp1 arrays.
995 #ifdef WRF_CHEM
996 do nvchem=1,num_chem
997 cbdy3dtemp1(ips:ipe,kps:kpe,jps:jpe)=cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem)
998 cbdy3dtemp2(ips:ipe,kps:kpe,jps:jpe)=nested_grid%chem(ips:ipe,kps:kpe,jps:jpe,nvchem)
999 ! if(nvchem.eq.p_o3)then
1000 ! write(0,*)'fill 1ch_b4',cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem),cbdy3dtemp2(ips,kps,jps)
1001 ! endif
1002 CALL stuff_bdytend ( cbdy3dtemp2 , cbdy3dtemp1 , new_bdy_frq , &
1003 nested_grid%chem_btxs(:,:,:,nvchem), nested_grid%chem_btxe(:,:,:,nvchem), &
1004 nested_grid%chem_btys(:,:,:,nvchem), nested_grid%chem_btye(:,:,:,nvchem), &
1005 'T' , &
1006 spec_bdy_width , &
1007 ids , ide , jds , jde , kds , kde , &
1008 ims , ime , jms , jme , kms , kme , &
1009 ips , ipe , jps , jpe , kps , kpe )
1010 cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem)=cbdy3dtemp2(ips:ipe,kps:kpe,jps:jpe)
1011 ! if(nvchem.eq.p_o3)then
1012 ! write(0,*)'fill 2ch_b4',cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem),cbdy3dtemp2(ips,kps,jps)
1013 ! endif
1014 enddo
1015 #endif
1016
1017 CALL stuff_bdytend ( ubdy3dtemp2 , ubdy3dtemp1 , new_bdy_frq , &
1018 nested_grid%em_u_btxs , nested_grid%em_u_btxe , &
1019 nested_grid%em_u_btys , nested_grid%em_u_btye , &
1020 'U' , &
1021 spec_bdy_width , &
1022 ids , ide , jds , jde , kds , kde , &
1023 ims , ime , jms , jme , kms , kme , &
1024 ips , ipe , jps , jpe , kps , kpe )
1025 CALL stuff_bdytend ( vbdy3dtemp2 , vbdy3dtemp1 , new_bdy_frq , &
1026 nested_grid%em_v_btxs , nested_grid%em_v_btxe , &
1027 nested_grid%em_v_btys , nested_grid%em_v_btye , &
1028 'V' , &
1029 spec_bdy_width , &
1030 ids , ide , jds , jde , kds , kde , &
1031 ims , ime , jms , jme , kms , kme , &
1032 ips , ipe , jps , jpe , kps , kpe )
1033 CALL stuff_bdytend ( tbdy3dtemp2 , tbdy3dtemp1 , new_bdy_frq , &
1034 nested_grid%em_t_btxs , nested_grid%em_t_btxe , &
1035 nested_grid%em_t_btys , nested_grid%em_t_btye , &
1036 'T' , &
1037 spec_bdy_width , &
1038 ids , ide , jds , jde , kds , kde , &
1039 ims , ime , jms , jme , kms , kme , &
1040 ips , ipe , jps , jpe , kps , kpe )
1041 CALL stuff_bdytend ( pbdy3dtemp2 , pbdy3dtemp1 , new_bdy_frq , &
1042 nested_grid%em_ph_btxs , nested_grid%em_ph_btxe , &
1043 nested_grid%em_ph_btys , nested_grid%em_ph_btye , &
1044 'W' , &
1045 spec_bdy_width , &
1046 ids , ide , jds , jde , kds , kde , &
1047 ims , ime , jms , jme , kms , kme , &
1048 ips , ipe , jps , jpe , kps , kpe )
1049 CALL stuff_bdytend ( qbdy3dtemp2 , qbdy3dtemp1 , new_bdy_frq , &
1050 nested_grid%moist_btxs(:,:,:,P_QV) , nested_grid%moist_btxe(:,:,:,P_QV) , &
1051 nested_grid%moist_btys(:,:,:,P_QV) , nested_grid%moist_btye(:,:,:,P_QV) , &
1052 'T' , &
1053 spec_bdy_width , &
1054 ids , ide , jds , jde , kds , kde , &
1055 ims , ime , jms , jme , kms , kme , &
1056 ips , ipe , jps , jpe , kps , kpe )
1057 CALL stuff_bdytend ( mbdy2dtemp2 , mbdy2dtemp1 , new_bdy_frq , &
1058 nested_grid%em_mu_btxs , nested_grid%em_mu_btxe , &
1059 nested_grid%em_mu_btys , nested_grid%em_mu_btye , &
1060 'M' , &
1061 spec_bdy_width , &
1062 ids , ide , jds , jde , 1 , 1 , &
1063 ims , ime , jms , jme , 1 , 1 , &
1064 ips , ipe , jps , jpe , 1 , 1 )
1065
1066 IF ( time_loop .EQ. 2 ) THEN
1067
1068 ! Generate an output file from this program, which will be an input file to WRF.
1069
1070 CALL wrf_debug ( 100 , 'ndown_em main: calling open_w_dataset for wrfbdy' )
1071 CALL construct_filename1( bdyname , 'wrfbdy' , nested_grid%id , 2 )
1072 CALL open_w_dataset ( fidb, TRIM(bdyname) , nested_grid , config_flags , output_boundary , &
1073 "DATASET=BOUNDARY", ierr )
1074 IF ( ierr .NE. 0 ) THEN
1075 WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'program ndown: error opening ',TRIM(bdyname),' for reading ierr=',ierr
1076 CALL WRF_ERROR_FATAL ( wrf_err_message )
1077 ENDIF
1078
1079 END IF
1080
1081 ! Both pieces of the boundary data are now available to be written.
1082
1083 CALL domain_clock_set( nested_grid, &
1084 current_timestr=current_date(1:19) )
1085 temp24= current_date
1086 temp24b=start_date_hold
1087 start_date = start_date_hold
1088 CALL geth_newdate ( temp19 , temp24b(1:19) , (time_loop-2) * model_config_rec%interval_seconds )
1089 current_date = temp19 // '.0000'
1090 CALL geth_julgmt ( julyr , julday , gmt)
1091 CALL nl_set_julyr ( nested_grid%id , julyr )
1092 CALL nl_set_julday ( nested_grid%id , julday )
1093 CALL nl_set_gmt ( nested_grid%id , gmt )
1094 CALL wrf_put_dom_ti_real ( fidb , 'GMT' , gmt , 1 , ierr )
1095 CALL wrf_put_dom_ti_integer ( fidb , 'JULYR' , julyr , 1 , ierr )
1096 CALL wrf_put_dom_ti_integer ( fidb , 'JULDAY' , julday , 1 , ierr )
1097 CALL domain_clock_set( nested_grid, &
1098 current_timestr=current_date(1:19) )
1099 CALL output_boundary ( fidb , nested_grid , config_flags , ierr )
1100 current_date = temp24
1101 start_date = temp24b
1102 CALL domain_clock_set( nested_grid, &
1103 current_timestr=current_date(1:19) )
1104
1105 IF ( time_loop .EQ. 2 ) THEN
1106 CALL wrf_put_dom_ti_real ( fidb , 'BDYFRQ' , new_bdy_frq , 1 , ierr )
1107 END IF
1108
1109 ! Since this is the last time through here, we need to close the boundary file.
1110
1111 CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags )
1112 CALL close_dataset ( fidb , config_flags , "DATASET=BOUNDARY" )
1113
1114
1115 END IF
1116
1117 ! Process which time now?
1118
1119 END DO big_time_loop_thingy
1120
1121 CALL model_to_grid_config_rec ( parent_grid%id , model_config_rec , config_flags )
1122 CALL med_shutdown_io ( parent_grid , config_flags )
1123
1124 CALL wrf_debug ( 0 , 'ndown_em: SUCCESS COMPLETE NDOWN_EM INIT' )
1125
1126 CALL wrf_shutdown
1127
1128 CALL WRFU_Finalize( rc=rc )
1129
1130 END PROGRAM ndown_em
1131
1132 SUBROUTINE land_percentages ( xland , &
1133 landuse_frac , soil_top_cat , soil_bot_cat , &
1134 isltyp , ivgtyp , &
1135 num_veg_cat , num_soil_top_cat , num_soil_bot_cat , &
1136 ids , ide , jds , jde , kds , kde , &
1137 ims , ime , jms , jme , kms , kme , &
1138 its , ite , jts , jte , kts , kte , &
1139 iswater )
1140 USE module_soil_pre
1141
1142 IMPLICIT NONE
1143
1144 INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
1145 ims , ime , jms , jme , kms , kme , &
1146 its , ite , jts , jte , kts , kte , &
1147 iswater
1148
1149 INTEGER , INTENT(IN) :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat
1150 REAL , DIMENSION(ims:ime,1:num_veg_cat,jms:jme) , INTENT(INOUT):: landuse_frac
1151 REAL , DIMENSION(ims:ime,1:num_soil_top_cat,jms:jme) , INTENT(IN):: soil_top_cat
1152 REAL , DIMENSION(ims:ime,1:num_soil_bot_cat,jms:jme) , INTENT(IN):: soil_bot_cat
1153 INTEGER , DIMENSION(ims:ime,jms:jme), INTENT(OUT) :: isltyp , ivgtyp
1154 REAL , DIMENSION(ims:ime,jms:jme) , INTENT(OUT) :: xland
1155
1156 CALL process_percent_cat_new ( xland , &
1157 landuse_frac , soil_top_cat , soil_bot_cat , &
1158 isltyp , ivgtyp , &
1159 num_veg_cat , num_soil_top_cat , num_soil_bot_cat , &
1160 ids , ide , jds , jde , kds , kde , &
1161 ims , ime , jms , jme , kms , kme , &
1162 its , ite , jts , jte , kts , kte , &
1163 iswater )
1164
1165 END SUBROUTINE land_percentages
1166
1167 SUBROUTINE check_consistency ( ivgtyp , isltyp , landmask , &
1168 ids , ide , jds , jde , kds , kde , &
1169 ims , ime , jms , jme , kms , kme , &
1170 its , ite , jts , jte , kts , kte , &
1171 iswater )
1172
1173 IMPLICIT NONE
1174
1175 INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
1176 ims , ime , jms , jme , kms , kme , &
1177 its , ite , jts , jte , kts , kte , &
1178 iswater
1179 INTEGER , DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: isltyp , ivgtyp
1180 REAL , DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: landmask
1181
1182 LOGICAL :: oops
1183 INTEGER :: oops_count , i , j
1184
1185 oops = .FALSE.
1186 oops_count = 0
1187
1188 DO j = jts, MIN(jde-1,jte)
1189 DO i = its, MIN(ide-1,ite)
1190 IF ( ( ( landmask(i,j) .LT. 0.5 ) .AND. ( ivgtyp(i,j) .NE. iswater ) ) .OR. &
1191 ( ( landmask(i,j) .GT. 0.5 ) .AND. ( ivgtyp(i,j) .EQ. iswater ) ) ) THEN
1192 print *,'mismatch in landmask and veg type'
1193 print *,'i,j=',i,j, ' landmask =',NINT(landmask(i,j)),' ivgtyp=',ivgtyp(i,j)
1194 oops = .TRUE.
1195 oops_count = oops_count + 1
1196 landmask(i,j) = 0
1197 ivgtyp(i,j)=16
1198 isltyp(i,j)=14
1199 END IF
1200 END DO
1201 END DO
1202
1203 IF ( oops ) THEN
1204 CALL wrf_debug( 0, 'mismatch in check_consistency, turned to water points, be careful' )
1205 END IF
1206
1207 END SUBROUTINE check_consistency
1208
1209 SUBROUTINE check_consistency2( ivgtyp , isltyp , landmask , &
1210 tmn , tsk , sst , xland , &
1211 tslb , smois , sh2o , &
1212 num_soil_layers , id , &
1213 ids , ide , jds , jde , kds , kde , &
1214 ims , ime , jms , jme , kms , kme , &
1215 its , ite , jts , jte , kts , kte , &
1216 iswater )
1217
1218 USE module_configure
1219 USE module_optional_si_input
1220
1221 INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
1222 ims , ime , jms , jme , kms , kme , &
1223 its , ite , jts , jte , kts , kte
1224 INTEGER , INTENT(IN) :: num_soil_layers , id
1225
1226 INTEGER , DIMENSION(ims:ime,jms:jme) :: ivgtyp , isltyp
1227 REAL , DIMENSION(ims:ime,jms:jme) :: landmask , tmn , tsk , sst , xland
1228 REAL , DIMENSION(ims:ime,num_soil_layers,jms:jme) :: tslb , smois , sh2o
1229
1230 INTEGER :: oops1 , oops2
1231 INTEGER :: i , j , k
1232
1233 fix_tsk_tmn : SELECT CASE ( model_config_rec%sf_surface_physics(id) )
1234
1235 CASE ( SLABSCHEME , LSMSCHEME , RUCLSMSCHEME )
1236 DO j = jts, MIN(jde-1,jte)
1237 DO i = its, MIN(ide-1,ite)
1238 IF ( ( landmask(i,j) .LT. 0.5 ) .AND. ( flag_sst .EQ. 1 ) ) THEN
1239 tmn(i,j) = sst(i,j)
1240 tsk(i,j) = sst(i,j)
1241 ELSE IF ( landmask(i,j) .LT. 0.5 ) THEN
1242 tmn(i,j) = tsk(i,j)
1243 END IF
1244 END DO
1245 END DO
1246 END SELECT fix_tsk_tmn
1247
1248 ! Is the TSK reasonable?
1249
1250 DO j = jts, MIN(jde-1,jte)
1251 DO i = its, MIN(ide-1,ite)
1252 IF ( tsk(i,j) .LT. 170 .or. tsk(i,j) .GT. 400. ) THEN
1253 print *,'error in the TSK'
1254 print *,'i,j=',i,j
1255 print *,'landmask=',landmask(i,j)
1256 print *,'tsk, sst, tmn=',tsk(i,j),sst(i,j),tmn(i,j)
1257 if(tmn(i,j).gt.170. .and. tmn(i,j).lt.400.)then
1258 tsk(i,j)=tmn(i,j)
1259 else if(sst(i,j).gt.170. .and. sst(i,j).lt.400.)then
1260 tsk(i,j)=sst(i,j)
1261 else
1262 CALL wrf_error_fatal ( 'TSK unreasonable' )
1263 end if
1264 END IF
1265 END DO
1266 END DO
1267
1268 ! Is the TMN reasonable?
1269
1270 DO j = jts, MIN(jde-1,jte)
1271 DO i = its, MIN(ide-1,ite)
1272 IF ( ( ( tmn(i,j) .LT. 170. ) .OR. ( tmn(i,j) .GT. 400. ) ) .AND. ( landmask(i,j) .GT. 0.5 ) ) THEN
1273 print *,'error in the TMN'
1274 print *,'i,j=',i,j
1275 print *,'landmask=',landmask(i,j)
1276 print *,'tsk, sst, tmn=',tsk(i,j),sst(i,j),tmn(i,j)
1277 if(tsk(i,j).gt.170. .and. tsk(i,j).lt.400.)then
1278 tmn(i,j)=tsk(i,j)
1279 else if(sst(i,j).gt.170. .and. sst(i,j).lt.400.)then
1280 tmn(i,j)=sst(i,j)
1281 else
1282 CALL wrf_error_fatal ( 'TMN unreasonable' )
1283 endif
1284 END IF
1285 END DO
1286 END DO
1287
1288 ! Is the TSLB reasonable?
1289
1290 DO j = jts, MIN(jde-1,jte)
1291 DO i = its, MIN(ide-1,ite)
1292 IF ( ( ( tslb(i,1,j) .LT. 170. ) .OR. ( tslb(i,1,j) .GT. 400. ) ) .AND. ( landmask(i,j) .GT. 0.5 ) ) THEN
1293 print *,'error in the TSLB'
1294 print *,'i,j=',i,j
1295 print *,'landmask=',landmask(i,j)
1296 print *,'tsk, sst, tmn=',tsk(i,j),sst(i,j),tmn(i,j)
1297 print *,'tslb = ',tslb(i,:,j)
1298 print *,'old smois = ',smois(i,:,j)
1299 DO l = 1 , num_soil_layers
1300 sh2o(i,l,j) = 0.0
1301 END DO
1302 DO l = 1 , num_soil_layers
1303 smois(i,l,j) = 0.3
1304 END DO
1305 if(tsk(i,j).gt.170. .and. tsk(i,j).lt.400.)then
1306 DO l = 1 , num_soil_layers
1307 tslb(i,l,j)=tsk(i,j)
1308 END DO
1309 else if(sst(i,j).gt.170. .and. sst(i,j).lt.400.)then
1310 DO l = 1 , num_soil_layers
1311 tslb(i,l,j)=sst(i,j)
1312 END DO
1313 else if(tmn(i,j).gt.170. .and. tmn(i,j).lt.400.)then
1314 DO l = 1 , num_soil_layers
1315 tslb(i,l,j)=tmn(i,j)
1316 END DO
1317 else
1318 CALL wrf_error_fatal ( 'TSLB unreasonable' )
1319 endif
1320 END IF
1321 END DO
1322 END DO
1323
1324 ! Let us make sure (again) that the landmask and the veg/soil categories match.
1325
1326 oops1=0
1327 oops2=0
1328 DO j = jts, MIN(jde-1,jte)
1329 DO i = its, MIN(ide-1,ite)
1330 IF ( ( ( landmask(i,j) .LT. 0.5 ) .AND. ( ivgtyp(i,j) .NE. iswater .OR. isltyp(i,j) .NE. 14 ) ) .OR. &
1331 ( ( landmask(i,j) .GT. 0.5 ) .AND. ( ivgtyp(i,j) .EQ. iswater .OR. isltyp(i,j) .EQ. 14 ) ) ) THEN
1332 IF ( tslb(i,1,j) .GT. 1. ) THEN
1333 oops1=oops1+1
1334 ivgtyp(i,j) = 5
1335 isltyp(i,j) = 8
1336 landmask(i,j) = 1
1337 xland(i,j) = 1
1338 ELSE IF ( sst(i,j) .GT. 1. ) THEN
1339 oops2=oops2+1
1340 ivgtyp(i,j) = iswater
1341 isltyp(i,j) = 14
1342 landmask(i,j) = 0
1343 xland(i,j) = 2
1344 ELSE
1345 print *,'the landmask and soil/veg cats do not match'
1346 print *,'i,j=',i,j
1347 print *,'landmask=',landmask(i,j)
1348 print *,'ivgtyp=',ivgtyp(i,j)
1349 print *,'isltyp=',isltyp(i,j)
1350 print *,'iswater=', iswater
1351 print *,'tslb=',tslb(i,:,j)
1352 print *,'sst=',sst(i,j)
1353 CALL wrf_error_fatal ( 'mismatch_landmask_ivgtyp' )
1354 END IF
1355 END IF
1356 END DO
1357 END DO
1358 if (oops1.gt.0) then
1359 print *,'points artificially set to land : ',oops1
1360 endif
1361 if(oops2.gt.0) then
1362 print *,'points artificially set to water: ',oops2
1363 endif
1364
1365 END SUBROUTINE check_consistency2
1366
1367 SUBROUTINE init_domain_constants_em_ptr ( parent , nest )
1368 USE module_domain
1369 USE module_configure
1370 IMPLICIT NONE
1371 TYPE(domain), POINTER :: parent , nest
1372 INTERFACE
1373 SUBROUTINE init_domain_constants_em ( parent , nest )
1374 USE module_domain
1375 USE module_configure
1376 TYPE(domain) :: parent , nest
1377 END SUBROUTINE init_domain_constants_em
1378 END INTERFACE
1379 CALL init_domain_constants_em ( parent , nest )
1380 END SUBROUTINE init_domain_constants_em_ptr