convert_fireemiss.F
References to this file elsewhere.
1 ! This is a program that converts fireemissions data
2 ! into WRF input data.
3 !
4
5 PROGRAM convert_fireemiss
6 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7
8 USE module_machine
9 USE module_domain
10 USE module_initialize
11 USE module_integrate
12 USE module_driver_constants
13 USE module_configure
14 USE module_io_wrf
15 USE module_io_domain
16 USE module_timing
17 USE module_utility
18 USE module_wrf_error
19 USE module_input_chem_emissopt3
20 #ifdef DM_PARALLEL
21 USE module_dm
22 #endif
23
24 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
25 IMPLICIT NONE
26
27 INTERFACE
28 SUBROUTINE Setup_Timekeeping( grid )
29 USE module_domain
30 TYPE(domain), POINTER :: grid
31 END SUBROUTINE Setup_Timekeeping
32 END INTERFACE
33
34 REAL :: time
35
36 INTEGER :: loop , levels_to_process
37 INTEGER :: rc
38
39 TYPE(domain) , POINTER :: keep_grid, grid_ptr, null_domain, grid, ingrid
40 TYPE (grid_config_rec_type) :: config_flags, config_flags_in
41 INTEGER :: number_at_same_level
42
43 INTEGER :: max_dom, domain_id
44 INTEGER :: id1 , id , fid, ierr
45 INTEGER :: idum1, idum2 , ihour
46 #ifdef DM_PARALLEL
47 INTEGER :: nbytes
48 INTEGER, PARAMETER :: configbuflen = 4* CONFIG_BUF_LEN
49 INTEGER :: configbuf( configbuflen )
50 LOGICAL , EXTERNAL :: wrf_dm_on_monitor
51 #endif
52
53 REAL :: dt_from_file, tstart_from_file, tend_from_file
54 INTEGER :: ids , ide , jds , jde , kds , kde
55 INTEGER :: ims , ime , jms , jme , kms , kme
56 INTEGER :: i , j , k , idts, ntsd, emi_frame, nemi_frames
57 INTEGER :: debug_level = 0
58
59 CHARACTER (LEN=80) :: message
60
61 CHARACTER(LEN=24) :: previous_date , this_date , next_date
62 CHARACTER(LEN=19) :: start_date_char , end_date_char , current_date_char , next_date_char
63 CHARACTER(LEN= 4) :: loop_char
64
65 INTEGER :: start_year , start_month , start_day , start_hour , start_minute , start_second
66 INTEGER :: end_year , end_month , end_day , end_hour , end_minute , end_second
67 INTEGER :: interval_seconds , real_data_init_type
68 INTEGER :: time_loop_max , time_loop
69
70 REAL :: cen_lat, cen_lon, moad_cen_lat, truelat1, truelat2, gmt, stand_lon, dum1
71 INTEGER :: map_proj, julyr, julday, iswater, isice, isurban, isoilwater
72 CHARACTER(LEN= 8) :: chlanduse
73
74
75 CHARACTER (LEN=80) :: inpname , eminame, dum_str, wrfinname
76
77 ! these are needed on some compilers, eg compaq/alpha, to
78 ! permit pass by reference through the registry generated
79 ! interface to med_read_emissions, below
80 #ifdef DEREF_KLUDGE
81 INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33
82 #endif
83
84 ! Get the NAMELIST data for input.
85
86 ! Define the name of this program (program_name defined in module_domain)
87
88 program_name = "WRF V2.2 EMISSIONS INPT_OPT 3 PREPROCESSOR"
89
90 #ifdef DM_PARALLEL
91 CALL disable_quilting
92 #endif
93
94 ! CALL init_modules
95 CALL wrf_debug ( 100 , 'convert_emiss: calling init_modules ' )
96 CALL init_modules(1) ! Phase 1 returns after MPI_INIT() (if it is called)
97 CALL WRFU_Initialize( defaultCalendar=WRFU_CAL_GREGORIAN, rc=rc )
98 CALL init_modules(2) ! Phase 2 resumes after MPI_INIT() (if it is called)
99
100
101 #ifdef DM_PARALLEL
102 IF ( wrf_dm_on_monitor() ) THEN
103 CALL initial_config
104 CALL get_config_as_buffer( configbuf, configbuflen, nbytes )
105 CALL wrf_dm_bcast_bytes( configbuf, nbytes )
106 CALL set_config_as_buffer( configbuf, configbuflen )
107 ENDIF
108 CALL wrf_dm_initialize
109 #else
110 CALL initial_config
111 #endif
112
113 CALL wrf_message ( program_name )
114
115 CALL init_wrfio
116
117 ! ! Get the grid info from the wrfinput file
118
119 write(message,FMT='(A)') ' allocate for wrfinput_d01 '
120 CALL wrf_message ( program_name )
121 NULLIFY( null_domain )
122 CALL alloc_and_configure_domain ( domain_id = 1 , &
123 grid = head_grid , &
124 parent = null_domain , &
125 kid = -1 )
126 write(message,FMT='(A)') ' pointer for wrfinput_d01 '
127 CALL wrf_debug ( 100, message )
128 grid => head_grid
129 write(message,FMT='(A)') ' set scalars for wrfinput_d01 '
130 CALL wrf_debug ( 100, message )
131 CALL set_scalar_indices_from_config ( grid%id , idum1, idum2 )
132
133 write(message,FMT='(A)') ' construct filename for wrfinput_d01 '
134 CALL wrf_debug ( 100, message )
135 CALL construct_filename1( wrfinname , 'wrfinput' , grid%id , 2 )
136
137 write(message,FMT='(A,A)') ' open file ',TRIM(wrfinname)
138 CALL wrf_message ( message )
139 CALL open_r_dataset ( fid, TRIM(wrfinname) , grid , config_flags , "DATASET=INPUT", ierr )
140
141
142 write(message,FMT='(A)') ' wrfinput open error check '
143 CALL wrf_debug ( 100, message )
144 IF ( ierr .NE. 0 ) THEN
145 WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) &
146 'program convert_emiss: error opening ',TRIM(wrfinname),' for reading ierr=',ierr
147 CALL WRF_ERROR_FATAL ( wrf_err_message )
148 ENDIF
149 write(message,FMT='(A)') ' past opening wrfinput_d01 '
150 CALL wrf_debug ( 100, message )
151
152 CALL wrf_get_dom_ti_integer ( fid , 'MAP_PROJ' , map_proj , 1 , idum1 , ierr )
153 CALL wrf_get_dom_ti_real ( fid , 'CEN_LAT' , cen_lat , 1 , idum1 , ierr )
154 CALL wrf_get_dom_ti_real ( fid , 'CEN_LON' , cen_lon , 1 , idum1 , ierr )
155 CALL wrf_get_dom_ti_real ( fid , 'MOAD_CEN_LAT' , moad_cen_lat , 1 , idum1 , ierr )
156 CALL wrf_get_dom_ti_real ( fid , 'STAND_LON' , stand_lon , 1 , idum1 , ierr )
157 CALL wrf_get_dom_ti_real ( fid , 'TRUELAT1' , truelat1 , 1 , idum1 , ierr )
158 CALL wrf_get_dom_ti_real ( fid , 'TRUELAT2' , truelat2 , 1 , idum1 , ierr )
159 CALL wrf_get_dom_ti_real ( fid , 'GMT' , gmt , 1 , idum1 , ierr )
160 CALL wrf_get_dom_ti_integer ( fid , 'JULYR' , julyr , 1 , idum1 , ierr )
161 CALL wrf_get_dom_ti_integer ( fid , 'JULDAY' , julday , 1 , idum1 , ierr )
162 CALL wrf_get_dom_ti_integer ( fid , 'ISWATER' , iswater , 1 , idum1 , ierr )
163 CALL wrf_get_dom_ti_integer ( fid , 'ISICE ' , isice , 1 , idum1 , ierr )
164 CALL wrf_get_dom_ti_integer ( fid , 'ISURBAN' , isurban , 1 , idum1 , ierr )
165 CALL wrf_get_dom_ti_integer ( fid , 'ISOILWATER' , isoilwater , 1 , idum1 , ierr )
166 CALL wrf_get_dom_ti_char ( fid , 'MMINLU' , chlanduse , ierr )
167
168 CALL close_dataset ( fid , config_flags , "DATASET=INPUT" )
169
170
171 ! An available simple timer from the timing module.
172
173 CALL set_scalar_indices_from_config ( grid%id , idum1, idum2 )
174
175 CALL Setup_Timekeeping ( grid )
176 CALL domain_clock_set( grid, &
177 time_step_seconds=model_config_rec%interval_seconds )
178 CALL domain_clock_get ( grid, current_timestr=message )
179 write(message,FMT='(A,A)') ' current_time ',Trim(message)
180 CALL wrf_debug ( 100, message )
181
182 CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags )
183
184 ! print *,'start date=',model_config_rec%start_year(grid%id),model_config_rec%start_month(grid%id),&
185 ! model_config_rec%start_day(grid%id),model_config_rec%start_hour(grid%id)
186 ! print *,'end date=',model_config_rec%end_year(grid%id),model_config_rec%end_month(grid%id),&
187 ! model_config_rec%end_day(grid%id),model_config_rec%end_hour(grid%id)
188 ! print *,'interval =',model_config_rec%interval_seconds
189 ! print *,'init_typ =',model_config_rec%real_data_init_type
190
191 ! Figure out the starting and ending dates in a character format.
192
193 start_year = model_config_rec%start_year (grid%id)
194 start_month = model_config_rec%start_month (grid%id)
195 start_day = model_config_rec%start_day (grid%id)
196 start_hour = model_config_rec%start_hour (grid%id)
197 start_minute = model_config_rec%start_minute(grid%id)
198 start_second = model_config_rec%start_second(grid%id)
199
200 end_year = model_config_rec% end_year (grid%id)
201 end_month = model_config_rec% end_month (grid%id)
202 end_day = model_config_rec% end_day (grid%id)
203 end_hour = model_config_rec% end_hour (grid%id)
204 end_minute = model_config_rec% end_minute(grid%id)
205 end_second = model_config_rec% end_second(grid%id)
206
207 interval_seconds = 3600
208 real_data_init_type = model_config_rec%real_data_init_type
209
210 WRITE ( start_date_char , FMT = '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) &
211 start_year,start_month,start_day,start_hour,start_minute,start_second
212 WRITE ( end_date_char , FMT = '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) &
213 end_year, end_month, end_day, end_hour, end_minute, end_second
214
215 ! these are needed on some compilers, eg compaq/alpha, to
216 ! permit pass by reference through the registry generated
217 ! interface to med_read_emissions, below
218 #ifdef DEREF_KLUDGE
219 sm31 = grid%sm31
220 em31 = grid%em31
221 sm32 = grid%sm32
222 em32 = grid%em32
223 sm33 = grid%sm33
224 em33 = grid%em33
225 #endif
226
227 ihour = start_hour
228 write(message,FMT='(A)') ' READ EMISSIONS OPT 3'
229 CALL wrf_debug ( 100, message )
230 CALL med_read_bin_chem_emissopt3( grid,config_flags )
231 write(message,FMT='(A)') ' PAST READ EMISSIONS '
232 CALL wrf_debug ( 100, message )
233
234 grid%input_from_file = .false.
235
236 write(message,FMT='(A)') ' OPEN EMISSIONS WRF file'
237 CALL wrf_debug ( 100, message )
238
239 CALL construct_filename1( inpname , 'wrffirechemi' , grid%id , 2 )
240 CALL open_w_dataset ( id1, TRIM(inpname) , grid , config_flags , output_aux_model_input5 , "DATASET=AUXINPUT5", ierr )
241 ! grid%input_from_file = .true.
242 ! write(message,FMT='(A)') ' READ FIRE EMISSIONS OPT 3'
243 ! CALL wrf_debug ( 100, message )
244 ! CALL med_read_bin_chem_emissopt3( grid,config_flags )
245 ! write(message,FMT='(A)') ' PAST READ FIRE EMISSIONS '
246 ! grid%input_from_file = .false.
247 ! CALL wrf_debug ( 100, message )
248 ! write(message,FMT='(A,A)') ' EMISSIONS file name: ',TRIM(inpname)
249 ! CALL wrf_message ( message )
250 ! CALL construct_filename1( inpname , 'wrfchemi' , grid%id , 2 )
251 ! CALL open_w_dataset ( id1, TRIM(inpname) , grid , config_flags , output_aux_model_input5 , "DATASET=AUXINPUT5", ierr )
252 ! write(message,FMT='(A,A)') ' EMISSIONS file name: ',TRIM(inpname)
253 ! CALL wrf_message ( message )
254
255 IF ( ierr .NE. 0 ) THEN
256 CALL wrf_error_fatal( 'real: error opening wrfchem emissions file for writing' )
257 ENDIF
258
259 write(message,FMT='(A)') ' PAST OPEN EMISSIONS WRF file '
260 CALL wrf_debug ( 100, message )
261
262 CALL calc_current_date ( grid%id , 0. )
263 CALL geth_newdate ( current_date_char, current_date, 3600 )
264 current_date = current_date_char // '.0000'
265
266 if( stand_lon == 0. ) then
267 stand_lon = cen_lon
268 endif
269
270 if( moad_cen_lat == 0. ) then
271 moad_cen_lat = cen_lat
272 endif
273
274 CALL output_aux_model_input5 ( id1 , grid , config_flags , ierr )
275 ! CALL output_aux_model_input7 ( id1 , grid , config_flags , ierr )
276
277 write(message,FMT='(A)') ' EMISSIONS: fix global attributes '
278 CALL wrf_debug ( 100, message )
279
280 ! write global atributes into wrf emissions file
281
282 idum1 = 1
283 call wrf_put_dom_ti_char ( id1 , 'START_DATE' ,TRIM(start_date_char) , ierr )
284 CALL wrf_put_dom_ti_integer ( id1 , 'MAP_PROJ' , map_proj , 1 , ierr )
285 CALL wrf_put_dom_ti_real ( id1 , 'MOAD_CEN_LAT' , moad_cen_lat, 1 , ierr )
286 CALL wrf_put_dom_ti_real ( id1 , 'CEN_LAT' , cen_lat , 1 , ierr )
287 CALL wrf_put_dom_ti_real ( id1 , 'CEN_LON' , cen_lon , 1 , ierr )
288 CALL wrf_put_dom_ti_real ( id1 , 'STAND_LON' , stand_lon , 1 , ierr )
289 CALL wrf_put_dom_ti_real ( id1 , 'TRUELAT1' , truelat1 , 1 , ierr )
290 CALL wrf_put_dom_ti_real ( id1 , 'TRUELAT2' , truelat2 , 1 , ierr )
291 CALL wrf_put_dom_ti_real ( id1 , 'GMT' , gmt , 1 , ierr )
292 CALL wrf_put_dom_ti_integer ( id1 , 'JULYR' , julyr , 1 , ierr )
293 CALL wrf_put_dom_ti_integer ( id1 , 'JULDAY' , julday , 1 , ierr )
294 ! CALL wrf_put_dom_ti_integer ( id1 , 'CHEM_OPT' , chem_opt , 1 , ierr )
295 CALL wrf_put_dom_ti_integer ( id1 , 'ISWATER' , iswater , 1 , ierr )
296 CALL wrf_put_dom_ti_integer ( id1 , 'ISICE ' , isice , 1 , ierr )
297 CALL wrf_put_dom_ti_integer ( id1 , 'ISURBAN' , isurban , 1 , ierr )
298 CALL wrf_put_dom_ti_integer ( id1 , 'ISOILWATER' , isoilwater , 1 , ierr )
299 CALL wrf_put_dom_ti_char ( id1 , 'MMINLU' , TRIM(chlanduse) , ierr )
300
301
302 CALL close_dataset ( id1 , config_flags , "DATASET=AUXOUTPUT5" )
303
304 write(message,FMT='(A)') ' EMISSIONS: end of program '
305 CALL wrf_message ( message )
306
307
308 CALL wrf_shutdown
309 CALL WRFU_Finalize( rc=rc )
310
311 !#ifdef DM_PARALLEL
312 ! CALL wrf_dm_shutdown
313 !#endif
314
315 STOP
316
317 END PROGRAM convert_fireemiss