Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

output_wrf.F @ 1939

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

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

WRF: version v3.3
LMDZ: version v1818

More details in:

File size: 69.4 KB

Line
1	!WRF:MEDIATION:IO
2	! ---principal wrf output routine (called from routines in module_io_domain )
3	SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr )
4	USE module_io
5	USE module_wrf_error
6	USE module_io_wrf
7	USE module_domain
8	USE module_domain_type, ONLY : fieldlist
9	USE module_state_description
10	USE module_configure
11	! USE module_date_time
12	USE module_model_constants
13	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, switch
20	INTEGER, INTENT(INOUT) :: ierr
21
22	! Local data
23	INTEGER ids , ide , jds , jde , kds , kde , &
24	ims , ime , jms , jme , kms , kme , &
25	ips , ipe , jps , jpe , kps , kpe
26
27	TYPE( fieldlist ), POINTER :: p
28
29	INTEGER newswitch, itrace
30
31	INTEGER , DIMENSION(3) :: domain_start , domain_end
32	INTEGER , DIMENSION(3) :: memory_start , memory_end
33	INTEGER , DIMENSION(3) :: patch_start , patch_end
34	INTEGER i,j
35	INTEGER julyr, julday, idt, iswater , islake, map_proj
36	INTEGER filestate
37	LOGICAL dryrun
38	REAL gmt, cen_lat, cen_lon, bdyfrq , truelat1 , truelat2 , moad_cen_lat , stand_lon
39	INTEGER km_opt, diff_opt, damp_opt, &
40	mp_physics, ra_lw_physics, ra_sw_physics, sf_sfclay_physics, &
41	sf_surface_physics, bl_pbl_physics, cu_physics
42	REAL khdif, kvdif, swrad_scat, dampcoef
43	INTEGER sf_urban_physics, w_damping, smooth_option, feedback, surface_input_source, sst_update
44	#if (EM_CORE == 1)
45	INTEGER grid_id , parent_id , i_parent_start , j_parent_start , parent_grid_ratio
46	INTEGER diff_6th_opt
47	REAL diff_6th_factor
48	INTEGER grid_fdda, gfdda_interval_m, gfdda_end_h, if_ramping, &
49	obs_nudge_opt, obs_nudge_wind, obs_nudge_temp, obs_nudge_mois, obs_nudge_pstr, obs_idynin, obs_ionf
50	INTEGER grid_sfdda, sgfdda_interval_m, sgfdda_end_h
51	REAL fgdt, guv, gt, gq, gph, dtramp_min, &
52	obs_coef_wind, obs_coef_temp, obs_coef_mois, obs_coef_pstr, obs_dtramp, fdda_end
53	REAL guv_sfc, gt_sfc, gq_sfc, rinblw
54	INTEGER moist_adv_opt, scalar_adv_opt, tke_adv_opt
55	INTEGER save_topo_orig
56	#endif
57	CHARACTER (len=19) simulation_start_date
58	CHARACTER (len=len_current_date) current_date_save
59	INTEGER simulation_start_year , &
60	simulation_start_month , &
61	simulation_start_day , &
62	simulation_start_hour , &
63	simulation_start_minute , &
64	simulation_start_second
65	INTEGER rc
66	INTEGER :: io_form
67	LOGICAL, EXTERNAL :: multi_files
68	INTEGER, EXTERNAL :: use_package
69	INTEGER p_hr, p_min, p_sec, p_ms
70
71	CHARACTER*80 dname, memord
72	CHARACTER*256 message
73	CHARACTER*80 fname
74	CHARACTER*80 char_junk
75	CHARACTER(LEN=256) :: MMINLU
76	INTEGER ibuf(1)
77	REAL rbuf(1)
78	TYPE(WRFU_TimeInterval) :: bdy_increment
79	TYPE(WRFU_Time) :: next_time, currentTime, startTime
80	CHARACTER*40 :: next_datestr
81	INTEGER :: start_year , start_month , start_day , start_hour , start_minute , start_second
82	LOGICAL :: adjust
83
84	TYPE(WRFU_Time) :: ringTime, stopTime, curtime
85	TYPE(WRFU_TimeInterval) :: interval, tmpinterval
86	CHARACTER*80 alarmname, timestring, debuggal
87	INTEGER seconds, seconds2, iring
88
89	WRITE(wrf_err_message,*)'output_wrf: begin, fid = ',fid
90	CALL wrf_debug( 300 , wrf_err_message )
91
92	CALL modify_io_masks ( grid%id ) ! this adjusts the I/O masks according to the users run-time specs, if any
93
94	CALL wrf_inquire_filename ( fid , fname , filestate , ierr )
95	IF ( ierr /= 0 ) THEN
96	WRITE(wrf_err_message,*)'module_io_wrf: output_wrf: wrf_inquire_filename Status = ',ierr
97	CALL wrf_error_fatal( wrf_err_message )
98	ENDIF
99
100	WRITE(wrf_err_message,*)'output_wrf: fid,filestate = ',fid,filestate
101	CALL wrf_debug( 300 , wrf_err_message )
102
103	! io_form is used to determine if multi-file I/O is enabled and to
104	! control writing of format-specific time-independent metadata
105	io_form = io_form_for_stream( switch )
106
107	dryrun = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED )
108
109	WRITE(wrf_err_message,*)'output_wrf: dryrun = ',dryrun
110	CALL wrf_debug( 300 , wrf_err_message )
111
112	CALL get_ijk_from_grid ( grid , &
113	ids, ide, jds, jde, kds, kde, &
114	ims, ime, jms, jme, kms, kme, &
115	ips, ipe, jps, jpe, kps, kpe )
116
117	call nl_get_diff_opt ( 1, diff_opt )
118	call nl_get_km_opt ( 1, km_opt )
119	call nl_get_damp_opt ( 1, damp_opt )
120	call nl_get_dampcoef ( grid%id, dampcoef )
121	call nl_get_khdif ( grid%id, khdif )
122	call nl_get_kvdif ( grid%id, kvdif )
123	call nl_get_mp_physics ( grid%id, mp_physics )
124	call nl_get_ra_lw_physics ( grid%id, ra_lw_physics )
125	call nl_get_ra_sw_physics ( grid%id, ra_sw_physics )
126	call nl_get_sf_sfclay_physics ( grid%id, sf_sfclay_physics )
127	call nl_get_sf_surface_physics ( grid%id, sf_surface_physics )
128	call nl_get_bl_pbl_physics ( grid%id, bl_pbl_physics )
129	call nl_get_cu_physics ( grid%id, cu_physics )
130
131	! add nml variables in 2.2
132	call nl_get_surface_input_source ( 1 , surface_input_source )
133	call nl_get_sst_update ( 1 , sst_update )
134	call nl_get_feedback ( 1 , feedback )
135	call nl_get_smooth_option ( 1 , smooth_option )
136	call nl_get_swrad_scat ( 1 , swrad_scat )
137	call nl_get_sf_urban_physics ( 1 , sf_urban_physics )
138	call nl_get_w_damping ( 1 , w_damping )
139
140	#if (EM_CORE == 1)
141	CALL nl_get_moist_adv_opt ( grid%id , moist_adv_opt )
142	CALL nl_get_scalar_adv_opt ( grid%id , scalar_adv_opt )
143	CALL nl_get_tke_adv_opt ( grid%id , tke_adv_opt )
144	CALL nl_get_diff_6th_opt ( grid%id , diff_6th_opt )
145	CALL nl_get_diff_6th_factor ( grid%id , diff_6th_factor )
146	CALL nl_get_grid_fdda ( grid%id , grid_fdda )
147	CALL nl_get_auxinput10_end_h( grid%id , gfdda_end_h )
148	CALL nl_get_auxinput10_interval_m ( grid%id , gfdda_interval_m )
149	CALL nl_get_grid_sfdda ( grid%id , grid_sfdda )
150	CALL nl_get_auxinput9_end_h( grid%id , sgfdda_end_h )
151	CALL nl_get_auxinput9_interval_m ( grid%id , sgfdda_interval_m )
152
153	IF ( grid_fdda == 1 ) THEN
154	CALL nl_get_fgdt ( grid%id , fgdt )
155	CALL nl_get_guv ( grid%id , guv )
156	CALL nl_get_gt ( grid%id , gt )
157	CALL nl_get_gq ( grid%id , gq )
158	CALL nl_get_if_ramping ( 1 , if_ramping )
159	CALL nl_get_dtramp_min ( 1 , dtramp_min )
160	ENDIF
161
162	IF ( grid_fdda == 2 ) THEN
163	CALL nl_get_fgdt ( grid%id , fgdt )
164	CALL nl_get_guv ( grid%id , guv )
165	CALL nl_get_gt ( grid%id , gt )
166	CALL nl_get_gph ( grid%id , gph )
167	CALL nl_get_if_ramping ( 1 , if_ramping )
168	CALL nl_get_dtramp_min ( 1 , dtramp_min )
169	ENDIF
170
171	IF ( grid_sfdda == 1 ) THEN
172	CALL nl_get_guv_sfc ( grid%id , guv_sfc )
173	CALL nl_get_gt_sfc ( grid%id , gt_sfc )
174	CALL nl_get_gq_sfc ( grid%id , gq_sfc )
175	CALL nl_get_rinblw ( grid%id , rinblw )
176	ENDIF
177
178	CALL nl_get_obs_nudge_opt ( grid%id , obs_nudge_opt )
179	IF ( obs_nudge_opt == 1 ) THEN
180	CALL nl_get_fdda_end ( grid%id , fdda_end )
181	CALL nl_get_obs_nudge_wind ( grid%id , obs_nudge_wind )
182	CALL nl_get_obs_coef_wind ( grid%id , obs_coef_wind )
183	CALL nl_get_obs_nudge_temp ( grid%id , obs_nudge_temp )
184	CALL nl_get_obs_coef_temp ( grid%id , obs_coef_temp )
185	CALL nl_get_obs_nudge_mois ( grid%id , obs_nudge_mois )
186	CALL nl_get_obs_coef_mois ( grid%id , obs_coef_mois )
187	CALL nl_get_obs_nudge_pstr ( grid%id , obs_nudge_pstr )
188	CALL nl_get_obs_coef_pstr ( grid%id , obs_coef_pstr )
189	CALL nl_get_obs_ionf ( 1 , obs_ionf )
190	CALL nl_get_obs_idynin ( 1 , obs_idynin )
191	CALL nl_get_obs_dtramp ( 1 , obs_dtramp )
192	ENDIF
193	#endif
194
195	! julday and gmt can be set in namelist_03 for ideal.exe run
196	CALL nl_get_gmt (grid%id, gmt)
197	CALL nl_get_julyr (grid%id, julyr)
198	CALL nl_get_julday (grid%id, julday)
199	CALL nl_get_mminlu ( grid%id, mminlu )
200	call wrf_debug(300,"OUTPUT_WRF: mminlu = " // mminlu )
201	CALL nl_get_iswater (grid%id, iswater )
202	CALL nl_get_islake (grid%id, islake )
203	CALL nl_get_cen_lat ( grid%id , cen_lat )
204	CALL nl_get_cen_lon ( grid%id , cen_lon )
205	CALL nl_get_truelat1 ( grid%id , truelat1 )
206	CALL nl_get_truelat2 ( grid%id , truelat2 )
207	CALL nl_get_moad_cen_lat ( grid%id , moad_cen_lat )
208	CALL nl_get_stand_lon ( grid%id , stand_lon )
209	CALL nl_get_map_proj ( grid%id , map_proj )
210
211	#if (EM_CORE == 1)
212	CALL nl_get_parent_id ( grid%id , parent_id )
213	CALL nl_get_i_parent_start ( grid%id , i_parent_start )
214	CALL nl_get_j_parent_start ( grid%id , j_parent_start )
215	CALL nl_get_parent_grid_ratio ( grid%id , parent_grid_ratio )
216	#endif
217
218	CALL domain_clockprint(150, grid, &
219	'DEBUG output_wrf(): before call to domain_clock_get,')
220	CALL domain_clock_get( grid, current_time=currentTime, &
221	start_time=startTime, &
222	current_timestr=current_date )
223
224	IF (switch .EQ. history_only) THEN
225	CALL nl_get_adjust_output_times( grid%id, adjust )
226	IF ( adjust ) THEN
227	CALL adjust_io_timestr( grid%io_intervals( history_alarm ), currentTime, startTime, timestring )
228	current_date_save = current_date
229	current_date = timestring
230	ENDIF
231	ENDIF
232
233	WRITE ( wrf_err_message , * ) 'output_wrf: begin, current_date=',current_date
234	CALL wrf_debug ( 300 , wrf_err_message )
235
236	WRITE( message , * ) "OUTPUT FROM " , TRIM(program_name)
237	CALL wrf_put_dom_ti_char ( fid , 'TITLE' , TRIM(message) , ierr )
238	! added grib-specific metadata: Todd Hutchinson 8/21/2005
239	IF ( ( use_package( io_form ) == IO_GRIB1 ) .OR. &
240	( use_package( io_form ) == IO_GRIB2 ) ) THEN
241	CALL wrf_put_dom_ti_char ( fid, 'PROGRAM_NAME', TRIM(program_name) , ierr )
242	ENDIF
243	CALL nl_get_start_year(grid%id,start_year)
244	CALL nl_get_start_month(grid%id,start_month)
245	CALL nl_get_start_day(grid%id,start_day)
246	CALL nl_get_start_hour(grid%id,start_hour)
247	CALL nl_get_start_minute(grid%id,start_minute)
248	CALL nl_get_start_second(grid%id,start_second)
249	#ifdef PLANET
250	WRITE ( start_date , FMT = '(I4.4,"-",I5.5,"_",I2.2,":",I2.2,":",I2.2)' ) &
251	start_year,start_day,start_hour,start_minute,start_second
252	#else
253	WRITE ( start_date , FMT = '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) &
254	start_year,start_month,start_day,start_hour,start_minute,start_second
255	#endif
256	CALL wrf_put_dom_ti_char ( fid , 'START_DATE', TRIM(start_date) , ierr )
257	IF ( switch .EQ. input_only) THEN
258	CALL wrf_put_dom_ti_char ( fid , 'SIMULATION_START_DATE', TRIM(start_date) , ierr )
259	ELSE IF ( ( switch .EQ. restart_only ) .OR. ( switch .EQ. history_only ) ) THEN
260	CALL nl_get_simulation_start_year ( 1, simulation_start_year )
261	CALL nl_get_simulation_start_month ( 1, simulation_start_month )
262	CALL nl_get_simulation_start_day ( 1, simulation_start_day )
263	CALL nl_get_simulation_start_hour ( 1, simulation_start_hour )
264	CALL nl_get_simulation_start_minute ( 1, simulation_start_minute )
265	CALL nl_get_simulation_start_second ( 1, simulation_start_second )
266	#ifdef PLANET
267	WRITE ( simulation_start_date , FMT = '(I4.4,"-",I5.5,"_",I2.2,":",I2.2,":",I2.2)' ) &
268	simulation_start_year,simulation_start_day,&
269	simulation_start_hour,simulation_start_minute,simulation_start_second
270	#else
271	WRITE ( simulation_start_date , FMT = '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) &
272	simulation_start_year,simulation_start_month,simulation_start_day,&
273	simulation_start_hour,simulation_start_minute,simulation_start_second
274	#endif
275	CALL wrf_put_dom_ti_char ( fid , 'SIMULATION_START_DATE', TRIM(simulation_start_date) , ierr )
276	END IF
277
278	IF ( switch .EQ. restart_only ) THEN
279	! add some delicious alarm metadata to the restart files
280	ibuf(1) = MAX_WRF_ALARMS
281	CALL wrf_put_dom_ti_integer( fid, 'MAX_WRF_ALARMS', ibuf, 1, ierr )
282	curtime = domain_get_current_time( grid )
283	DO i = 1, MAX_WRF_ALARMS
284	IF ( grid%alarms_created(i) ) THEN
285	IF ( i .LT. 10 ) THEN
286	write(alarmname,'("WRF_ALARM_ISRINGING_0",i1)')i
287	ELSE
288	write(alarmname,'("WRF_ALARM_ISRINGING_",i2)')i
289	ENDIF
290	IF ( WRFU_AlarmIsRinging( grid%alarms( i ), rc=rc ) ) THEN
291	iring = 1
292	ELSE
293	iring = 0
294	ENDIF
295	CALL wrf_put_dom_ti_integer( fid, TRIM(alarmname), iring, 1, ierr )
296
297	CALL WRFU_AlarmGet( grid%alarms(i),PrevRingTime=ringTime,RingInterval=interval,rc=rc)
298
299	#if 0
300	!different, perhaps simpler way to do this, JM 20100319
301	IF ( i .LT. 10 ) THEN
302	write(alarmname,'("WRF_ALARM_PREVRINGTIME_0",i1)')i
303	ELSE
304	write(alarmname,'("WRF_ALARM_PREVRINGTIME_",i2)')i
305	ENDIF
306	CALL WRFU_TimeGet( ringTime, timeString=prevringtime )
307	CALL wrf_put_dom_ti_char( fid, TRIM(alarmname), TRIM(prevringtime), 1, ierr )
308	#endif
309
310	! compute time to next ring as interval minus time since last ring
311	tmpinterval = curtime - ringTime
312
313	IF ( i .LT. 10 ) THEN
314	write(alarmname,'("WRF_ALARM_SECS_TIL_NEXT_RING_0",i1)')i
315	ELSE
316	write(alarmname,'("WRF_ALARM_SECS_TIL_NEXT_RING_",i2)')i
317	ENDIF
318	CALL WRFU_TimeIntervalGet(interval,S=seconds)
319	CALL WRFU_TimeIntervalGet(tmpinterval,S=seconds2)
320	IF ( seconds .GE. 1700000000 .OR. seconds .LE. -1700000000 ) THEN ! it is a forever value, do not change it
321	CALL wrf_put_dom_ti_integer( fid, TRIM(alarmname), seconds, 1, ierr )
322	ELSE
323	CALL wrf_put_dom_ti_integer( fid, TRIM(alarmname), seconds-seconds2, 1, ierr )
324	ENDIF
325	#if 0
326	if ( i .eq. history_alarm .or. i .eq. restart_alarm .or. i .eq. auxhist24_alarm) then
327	if ( i .eq. history_alarm ) write(,)'----------------- info for history alarm ',i
328	if ( i .eq. restart_alarm ) write(,)'----------------- info for restart alarm ',i
329	if ( i .eq. auxhist24_alarm ) write(,)'----------------- info for auxhist24 alarm ',i
330	CALL ESMF_TimeGet(curTime, TimeString=debuggal ) ; write(,)'curTime ',TRIM(debuggal)
331	CALL ESMF_TimeGet(ringTime, TimeString=debuggal ) ; write(,)'ringTime ',TRIM(debuggal)
332	CALL ESMF_TimeIntervalGet(tmpinterval, TimeString=debuggal ) ; write(,)'tmpinterval ',TRIM(debuggal)
333	CALL ESMF_TimeIntervalGet(interval, TimeString=debuggal ) ; write(,)'interval ',TRIM(debuggal)
334	write(,)'interval seconds ',seconds,' tmpinterval seconds ',seconds2,' seconds-seconds2 ',seconds-seconds2
335	write(,)'----------------- '
336	endif
337	#endif
338
339	ENDIF
340	ENDDO
341	ENDIF
342
343	ibuf(1) = config_flags%e_we - config_flags%s_we + 1
344	CALL wrf_put_dom_ti_integer ( fid , 'WEST-EAST_GRID_DIMENSION' , ibuf , 1 , ierr )
345
346	ibuf(1) = config_flags%e_sn - config_flags%s_sn + 1
347	CALL wrf_put_dom_ti_integer ( fid , 'SOUTH-NORTH_GRID_DIMENSION' , ibuf , 1 , ierr )
348
349	ibuf(1) = config_flags%e_vert - config_flags%s_vert + 1
350	CALL wrf_put_dom_ti_integer ( fid , 'BOTTOM-TOP_GRID_DIMENSION' , ibuf , 1 , ierr )
351
352	#if (EM_CORE == 1)
353	IF (grid%map_proj == 6) THEN
354	! Global ... dx determined automatically
355	! Don't use value from namelist ... used derived value instead
356	CALL wrf_put_dom_ti_real ( fid , 'DX' , grid%dx , 1 , ierr )
357	CALL wrf_put_dom_ti_real ( fid , 'DY' , grid%dy , 1 , ierr )
358	ELSE
359	CALL wrf_put_dom_ti_real ( fid , 'DX' , config_flags%dx , 1 , ierr )
360	CALL wrf_put_dom_ti_real ( fid , 'DY' , config_flags%dy , 1 , ierr )
361	END IF
362	#endif
363
364	#if (EM_CORE == 1)
365	!added the following for tc bogusing
366	if((config_flags%insert_bogus_storm) .or. (config_flags%remove_storm)) then
367	print *,"we have confirmed that insert or remove is true"
368	ibuf(1) = 1
369	CALL wrf_put_dom_ti_integer ( fid , 'FLAG_METGRID' , ibuf , 1 , ierr )
370	if( grid%flag_snow .eq. 1) then
371	CALL wrf_put_dom_ti_integer ( fid , 'FLAG_SNOW' , ibuf , 1 , ierr )
372	end if
373	if( grid%flag_mf_xy .eq. 1) then
374	CALL wrf_put_dom_ti_integer ( fid , 'FLAG_MF_XY' , ibuf , 1 , ierr )
375	end if
376	if(grid%flag_psfc .eq. 1) then
377	CALL wrf_put_dom_ti_integer ( fid , 'FLAG_PSFC' , ibuf , 1 , ierr )
378	end if
379
380	if(grid%flag_slp .eq. 1) then
381	CALL wrf_put_dom_ti_integer ( fid , 'FLAG_SLP' , ibuf , 1 , ierr )
382	end if
383
384	if(grid%flag_sm000010 .eq. 1)then
385	CALL wrf_put_dom_ti_integer ( fid , 'FLAG_SM000010' , ibuf , 1 , ierr )
386	end if
387	if(grid%flag_sm010040 .eq. 1)then
388	CALL wrf_put_dom_ti_integer ( fid , 'FLAG_SM010040' , ibuf , 1 , ierr )
389	end if
390	if(grid%flag_sm040100 .eq. 1)then
391	CALL wrf_put_dom_ti_integer ( fid , 'FLAG_SM040100' , ibuf , 1 , ierr )
392	end if
393	if(grid%flag_sm100200 .eq. 1)then
394	CALL wrf_put_dom_ti_integer ( fid , 'FLAG_SM100200' , ibuf , 1 , ierr )
395	end if
396
397	if(grid%flag_st000010 .eq. 1)then
398	CALL wrf_put_dom_ti_integer ( fid , 'FLAG_ST000010' , ibuf , 1 , ierr )
399	end if
400	if(grid%flag_st010040 .eq. 1)then
401	CALL wrf_put_dom_ti_integer ( fid , 'FLAG_ST010040' , ibuf , 1 , ierr )
402	end if
403	if(grid%flag_st040100 .eq. 1)then
404	CALL wrf_put_dom_ti_integer ( fid , 'FLAG_ST040100' , ibuf , 1 , ierr )
405	end if
406	if(grid%flag_st100200 .eq. 1)then
407	CALL wrf_put_dom_ti_integer ( fid , 'FLAG_ST100200' , ibuf , 1 , ierr )
408	end if
409
410	ibuf(1) = grid%num_metgrid_levels
411	CALL wrf_put_dom_ti_integer ( fid , 'BOTTOM-TOP_GRID_DIMENSION' , ibuf , 1 , ierr )
412
413	CALL wrf_put_dom_ti_integer ( fid , 'num_metgrid_levels' , ibuf , 1 , ierr )
414
415	print *,start_date
416	CALL wrf_put_dom_ti_char ( fid , 'SIMULATION_START_DATE', TRIM(start_date) , ierr )
417
418	WRITE( message , * ) "OUTPUT FROM TC BOGUS"
419	CALL wrf_put_dom_ti_char ( fid , 'TITLE' , TRIM(message) , ierr )
420	end if
421	#endif
422
423
424	! added this metadatum for H. Chuan, NCEP, 030417, JM
425	#if (NMM_CORE == 1)
426	CALL wrf_put_dom_ti_char ( fid , 'GRIDTYPE', 'E' , ierr )
427	#endif
428	#if (EM_CORE == 1)
429	CALL wrf_put_dom_ti_char ( fid , 'GRIDTYPE', 'C' , ierr )
430	#endif
431	#if (COAMPS_CORE == 1 )
432	CALL wrf_put_dom_ti_char ( fid , 'GRIDTYPE', 'B' , ierr )
433	#endif
434
435	! added these fields for W. Skamarock, 020402, JM
436	ibuf(1) = diff_opt
437	CALL wrf_put_dom_ti_integer ( fid , 'DIFF_OPT' , ibuf , 1 , ierr )
438	ibuf(1) = km_opt
439	CALL wrf_put_dom_ti_integer ( fid , 'KM_OPT' , ibuf , 1 , ierr )
440	ibuf(1) = damp_opt
441	CALL wrf_put_dom_ti_integer ( fid , 'DAMP_OPT' , ibuf , 1 , ierr )
442	rbuf(1) = dampcoef
443	CALL wrf_put_dom_ti_real ( fid , 'DAMPCOEF' , rbuf , 1 , ierr )
444	rbuf(1) = khdif
445	CALL wrf_put_dom_ti_real ( fid , 'KHDIF' , rbuf , 1 , ierr )
446	rbuf(1) = kvdif
447	CALL wrf_put_dom_ti_real ( fid , 'KVDIF' , rbuf , 1 , ierr )
448	ibuf(1) = mp_physics
449	CALL wrf_put_dom_ti_integer ( fid , 'MP_PHYSICS' , ibuf , 1 , ierr )
450	ibuf(1) = ra_lw_physics
451	CALL wrf_put_dom_ti_integer ( fid , 'RA_LW_PHYSICS' , ibuf , 1 , ierr )
452	ibuf(1) = ra_sw_physics
453	CALL wrf_put_dom_ti_integer ( fid , 'RA_SW_PHYSICS' , ibuf , 1 , ierr )
454	ibuf(1) = sf_sfclay_physics
455	CALL wrf_put_dom_ti_integer ( fid , 'SF_SFCLAY_PHYSICS' , ibuf , 1 , ierr )
456	ibuf(1) = sf_surface_physics
457	CALL wrf_put_dom_ti_integer ( fid , 'SF_SURFACE_PHYSICS' , ibuf , 1 , ierr )
458	ibuf(1) = bl_pbl_physics
459	CALL wrf_put_dom_ti_integer ( fid , 'BL_PBL_PHYSICS' , ibuf , 1 , ierr )
460	ibuf(1) = cu_physics
461	CALL wrf_put_dom_ti_integer ( fid , 'CU_PHYSICS' , ibuf , 1 , ierr )
462
463	! added netcdf-specific metadata:
464	IF ( ( use_package( io_form ) == IO_NETCDF ) .OR. &
465	( use_package( io_form ) == IO_PHDF5 ) .OR. &
466	( use_package( io_form ) == IO_PNETCDF ) ) THEN
467	CALL wrf_put_dom_ti_integer ( fid, 'SURFACE_INPUT_SOURCE', surface_input_source , 1 , ierr )
468	CALL wrf_put_dom_ti_integer ( fid, 'SST_UPDATE', sst_update , 1 , ierr )
469	#if (EM_CORE == 1)
470	CALL wrf_put_dom_ti_integer ( fid, 'GRID_FDDA', grid_fdda , 1 , ierr )
471	CALL wrf_put_dom_ti_integer ( fid, 'GFDDA_INTERVAL_M', gfdda_interval_m , 1 , ierr )
472	CALL wrf_put_dom_ti_integer ( fid, 'GFDDA_END_H', gfdda_end_h , 1 , ierr )
473	CALL wrf_put_dom_ti_integer ( fid, 'GRID_SFDDA', grid_sfdda , 1 , ierr )
474	CALL wrf_put_dom_ti_integer ( fid, 'SGFDDA_INTERVAL_M', sgfdda_interval_m , 1 , ierr )
475	CALL wrf_put_dom_ti_integer ( fid, 'SGFDDA_END_H', sgfdda_end_h , 1 , ierr )
476	#endif
477
478	IF ( switch .EQ. history_only ) THEN
479	CALL wrf_put_dom_ti_integer ( fid, 'SF_URBAN_PHYSICS', sf_urban_physics , 1 , ierr )
480	CALL wrf_put_dom_ti_integer ( fid, 'FEEDBACK', feedback , 1 , ierr )
481	CALL wrf_put_dom_ti_integer ( fid, 'SMOOTH_OPTION', smooth_option , 1 , ierr )
482	CALL wrf_put_dom_ti_real ( fid, 'SWRAD_SCAT', swrad_scat , 1 , ierr )
483	CALL wrf_put_dom_ti_integer ( fid, 'W_DAMPING', w_damping , 1 , ierr )
484
485	#if (EM_CORE == 1)
486	CALL wrf_put_dom_ti_integer ( fid, 'MOIST_ADV_OPT', moist_adv_opt , 1 , ierr )
487	CALL wrf_put_dom_ti_integer ( fid, 'SCALAR_ADV_OPT', scalar_adv_opt , 1 , ierr )
488	CALL wrf_put_dom_ti_integer ( fid, 'TKE_ADV_OPT', tke_adv_opt , 1 , ierr )
489	CALL wrf_put_dom_ti_integer ( fid, 'DIFF_6TH_OPT', diff_6th_opt , 1 , ierr )
490	CALL wrf_put_dom_ti_real ( fid, 'DIFF_6TH_FACTOR', diff_6th_factor , 1 , ierr )
491
492	IF ( grid_fdda == 1 ) THEN
493	CALL wrf_put_dom_ti_real ( fid, 'FGDT', fgdt , 1 , ierr )
494	CALL wrf_put_dom_ti_real ( fid, 'GUV', guv , 1 , ierr )
495	CALL wrf_put_dom_ti_real ( fid, 'GT', gt , 1 , ierr )
496	CALL wrf_put_dom_ti_real ( fid, 'GQ', gq , 1 , ierr )
497	CALL wrf_put_dom_ti_integer ( fid, 'IF_RAMPING', if_ramping , 1 , ierr )
498	CALL wrf_put_dom_ti_real ( fid, 'DTRAMP_MIN', dtramp_min , 1 , ierr )
499	ENDIF
500
501	IF ( grid_fdda == 2 ) THEN
502	CALL wrf_put_dom_ti_real ( fid, 'FGDT', fgdt , 1 , ierr )
503	CALL wrf_put_dom_ti_real ( fid, 'GUV', guv , 1 , ierr )
504	CALL wrf_put_dom_ti_real ( fid, 'GT', gt , 1 , ierr )
505	CALL wrf_put_dom_ti_real ( fid, 'GPH', gph , 1 , ierr )
506	CALL wrf_put_dom_ti_integer ( fid, 'IF_RAMPING', if_ramping , 1 , ierr )
507	CALL wrf_put_dom_ti_real ( fid, 'DTRAMP_MIN', dtramp_min , 1 , ierr )
508	ENDIF
509
510	IF ( grid_sfdda == 1 ) THEN
511	CALL wrf_put_dom_ti_real ( fid, 'GUV_SFC', guv_sfc , 1 , ierr )
512	CALL wrf_put_dom_ti_real ( fid, 'GT_SFC', gt_sfc , 1 , ierr )
513	CALL wrf_put_dom_ti_real ( fid, 'GQ_SFC', gq_sfc , 1 , ierr )
514	CALL wrf_put_dom_ti_real ( fid, 'RINBLW', rinblw , 1 , ierr )
515	ENDIF
516
517	CALL wrf_put_dom_ti_integer ( fid, 'OBS_NUDGE_OPT', obs_nudge_opt , 1 , ierr )
518	IF ( obs_nudge_opt == 1 ) THEN
519	CALL wrf_put_dom_ti_real ( fid, 'FDDA_END', fdda_end , 1 , ierr )
520	CALL wrf_put_dom_ti_integer ( fid, 'OBS_NUDGE_WIND', obs_nudge_wind , 1 , ierr )
521	CALL wrf_put_dom_ti_real ( fid, 'OBS_COEF_WIND', obs_coef_wind , 1 , ierr )
522	CALL wrf_put_dom_ti_integer ( fid, 'OBS_NUDGE_TEMP', obs_nudge_temp , 1 , ierr )
523	CALL wrf_put_dom_ti_real ( fid, 'OBS_COEF_TEMP', obs_coef_temp , 1 , ierr )
524	CALL wrf_put_dom_ti_integer ( fid, 'OBS_NUDGE_MOIS', obs_nudge_mois , 1 , ierr )
525	CALL wrf_put_dom_ti_real ( fid, 'OBS_COEF_MOIS', obs_coef_mois , 1 , ierr )
526	CALL wrf_put_dom_ti_integer ( fid, 'OBS_NUDGE_PSTR', obs_nudge_pstr , 1 , ierr )
527	CALL wrf_put_dom_ti_real ( fid, 'OBS_COEF_PSTR', obs_coef_pstr , 1 , ierr )
528	CALL wrf_put_dom_ti_integer ( fid, 'OBS_IONF', obs_ionf , 1 , ierr )
529	CALL wrf_put_dom_ti_integer ( fid, 'OBS_IDYNIN', obs_idynin , 1 , ierr )
530	CALL wrf_put_dom_ti_real ( fid, 'OBS_DTRAMP', obs_dtramp , 1 , ierr )
531	ENDIF
532
533	CALL wrf_put_dom_ti_real ( fid, 'BUCKET_MM', config_flags%bucket_mm , 1 , ierr )
534	CALL wrf_put_dom_ti_real ( fid, 'BUCKET_J', config_flags%bucket_J , 1 , ierr )
535	CALL wrf_put_dom_ti_real ( fid, 'PREC_ACC_DT', config_flags%prec_acc_dt , 1 , ierr )
536	CALL wrf_put_dom_ti_integer ( fid, 'OMLCALL', config_flags%omlcall , 1 , ierr )
537	CALL wrf_put_dom_ti_integer ( fid, 'ISFTCFLX', config_flags%isftcflx , 1 , ierr )
538	CALL wrf_put_dom_ti_integer ( fid, 'ISHALLOW', config_flags%ishallow , 1 , ierr )
539
540	#endif
541
542	CALL wrf_put_dom_ti_integer ( fid, 'DFI_OPT', config_flags%dfi_opt , 1 , ierr )
543	CALL wrf_put_dom_ti_integer ( fid, 'SHCU_PHYSICS', config_flags%shcu_physics , 1 , ierr )
544	CALL wrf_put_dom_ti_integer ( fid, 'SF_URBAN_PHYSICS', config_flags%sf_urban_physics , 1 , ierr )
545
546	ENDIF ! history_only
547	ENDIF
548
549	! added these fields for use by reassembly programs , 010831, JM
550	! modified these fields so "patch" == "domain" when multi-file output
551	! formats are not used. 051018, TBH
552
553	ibuf(1) = MAX(ips,ids)
554	IF ( .NOT. multi_files ( io_form ) ) ibuf(1) = ids
555	CALL wrf_put_dom_ti_integer ( fid , 'WEST-EAST_PATCH_START_UNSTAG' , ibuf , 1 , ierr )
556	ibuf(1) = MIN(ipe,ide-1)
557	IF ( .NOT. multi_files ( io_form ) ) ibuf(1) = ide - 1
558	CALL wrf_put_dom_ti_integer ( fid , 'WEST-EAST_PATCH_END_UNSTAG' , ibuf , 1 , ierr )
559	ibuf(1) = MAX(ips,ids)
560	IF ( .NOT. multi_files ( io_form ) ) ibuf(1) = ids
561	CALL wrf_put_dom_ti_integer ( fid , 'WEST-EAST_PATCH_START_STAG' , ibuf , 1 , ierr )
562	ibuf(1) = MIN(ipe,ide)
563	IF ( .NOT. multi_files ( io_form ) ) ibuf(1) = ide
564	CALL wrf_put_dom_ti_integer ( fid , 'WEST-EAST_PATCH_END_STAG' , ibuf , 1 , ierr )
565	ibuf(1) = MAX(jps,jds)
566	IF ( .NOT. multi_files ( io_form ) ) ibuf(1) = jds
567	CALL wrf_put_dom_ti_integer ( fid , 'SOUTH-NORTH_PATCH_START_UNSTAG' , ibuf , 1 , ierr )
568	ibuf(1) = MIN(jpe,jde-1)
569	IF ( .NOT. multi_files ( io_form ) ) ibuf(1) = jde - 1
570	CALL wrf_put_dom_ti_integer ( fid , 'SOUTH-NORTH_PATCH_END_UNSTAG' , ibuf , 1 , ierr )
571	ibuf(1) = MAX(jps,jds)
572	IF ( .NOT. multi_files ( io_form ) ) ibuf(1) = jds
573	CALL wrf_put_dom_ti_integer ( fid , 'SOUTH-NORTH_PATCH_START_STAG' , ibuf , 1 , ierr )
574	ibuf(1) = MIN(jpe,jde)
575	IF ( .NOT. multi_files ( io_form ) ) ibuf(1) = jde
576	CALL wrf_put_dom_ti_integer ( fid , 'SOUTH-NORTH_PATCH_END_STAG' , ibuf , 1 , ierr )
577
578	ibuf(1) = MAX(kps,kds)
579	IF ( .NOT. multi_files ( io_form ) ) ibuf(1) = kds
580	CALL wrf_put_dom_ti_integer ( fid , 'BOTTOM-TOP_PATCH_START_UNSTAG' , ibuf , 1 , ierr )
581	ibuf(1) = MIN(kpe,kde-1)
582	IF ( .NOT. multi_files ( io_form ) ) ibuf(1) = kde - 1
583	CALL wrf_put_dom_ti_integer ( fid , 'BOTTOM-TOP_PATCH_END_UNSTAG' , ibuf , 1 , ierr )
584	ibuf(1) = MAX(kps,kds)
585	IF ( .NOT. multi_files ( io_form ) ) ibuf(1) = kds
586	CALL wrf_put_dom_ti_integer ( fid , 'BOTTOM-TOP_PATCH_START_STAG' , ibuf , 1 , ierr )
587	ibuf(1) = MIN(kpe,kde)
588	IF ( .NOT. multi_files ( io_form ) ) ibuf(1) = kde
589	CALL wrf_put_dom_ti_integer ( fid , 'BOTTOM-TOP_PATCH_END_STAG' , ibuf , 1 , ierr )
590	#if (EM_CORE == 1)
591	ibuf(1) = grid%id
592	CALL wrf_put_dom_ti_integer ( fid , 'GRID_ID' , ibuf , 1 , ierr )
593	ibuf(1) = parent_id
594	CALL wrf_put_dom_ti_integer ( fid , 'PARENT_ID' , ibuf , 1 , ierr )
595	ibuf(1) = i_parent_start
596	CALL wrf_put_dom_ti_integer ( fid , 'I_PARENT_START' , ibuf , 1 , ierr )
597	ibuf(1) = j_parent_start
598	CALL wrf_put_dom_ti_integer ( fid , 'J_PARENT_START' , ibuf , 1 , ierr )
599	ibuf(1) = parent_grid_ratio
600	CALL wrf_put_dom_ti_integer ( fid , 'PARENT_GRID_RATIO' , ibuf , 1 , ierr )
601	#endif
602
603	! end add 010831 JM
604
605	#if (EM_CORE != 1)
606	CALL wrf_put_dom_ti_real ( fid , 'DX' , config_flags%dx , 1 , ierr )
607	CALL wrf_put_dom_ti_real ( fid , 'DY' , config_flags%dy , 1 , ierr )
608	#endif
609	! Updated by T. Hutchinson to use adaptive time step.
610	CALL wrf_put_dom_ti_real ( fid , 'DT' , grid%dt , 1 , ierr )
611	! CALL wrf_put_dom_ti_real ( fid , 'DT' , config%dt , 1 , ierr )
612	CALL wrf_put_dom_ti_real ( fid , 'CEN_LAT' , config_flags%cen_lat , 1 , ierr )
613	CALL wrf_put_dom_ti_real ( fid , 'CEN_LON' , config_flags%cen_lon , 1 , ierr )
614	CALL wrf_put_dom_ti_real ( fid , 'TRUELAT1', config_flags%truelat1, 1 , ierr )
615	CALL wrf_put_dom_ti_real ( fid , 'TRUELAT2', config_flags%truelat2, 1 , ierr )
616	CALL wrf_put_dom_ti_real ( fid , 'MOAD_CEN_LAT', config_flags%moad_cen_lat, 1 , ierr )
617	CALL wrf_put_dom_ti_real ( fid , 'STAND_LON', config_flags%stand_lon, 1 , ierr )
618	#if (EM_CORE == 1)
619	CALL wrf_put_dom_ti_real ( fid , 'POLE_LAT', config_flags%pole_lat, 1 , ierr )
620	CALL wrf_put_dom_ti_real ( fid , 'POLE_LON', config_flags%pole_lon, 1 , ierr )
621	#endif
622	IF ( switch .NE. boundary_only .AND. switch .NE. auxinput9_only .AND. switch .NE. auxinput10_only ) THEN
623	#ifdef PLANET
624	! When writing to restart files, use the values of the instantaneous
625	! time for determining the values of JULYR, JULDAY, and GMT. If the
626	! original values in config_flags are used, this assumes that the
627	! restart simulation will start with an itimestep NE 0. If we use
628	! the instantaneous time, we can start a restart simulation with a
629	! different value of delta-t for timestep and still get the clocks
630	! calendars (and orbital information!) correct.
631	!
632	! Current time is still defined from above call to WRF_UTIL_ClockGet
633	CALL WRFU_TimeGet( currentTime, YY=julyr, dayOfYear=julday, H=p_hr, M=p_min, S=p_sec, MS=p_ms, rc=rc)
634	WRITE(wrf_err_message,*)'output_wrf: julyr,julday,hr,min,sec,ms = ',julyr,julday,p_hr,p_min,p_sec,p_ms
635	CALL wrf_debug( 100 , wrf_err_message )
636	gmt = REAL(p_hr)+REAL(p_min)/60.+REAL(p_sec)/3600.+REAL(p_ms)/3600000.
637	CALL wrf_put_dom_ti_real ( fid , 'GMT' , gmt , 1 , ierr )
638	CALL wrf_put_dom_ti_integer ( fid , 'JULYR' , julyr , 1 , ierr )
639	CALL wrf_put_dom_ti_integer ( fid , 'JULDAY' , julday , 1 , ierr )
640	#else
641	CALL wrf_put_dom_ti_real ( fid , 'GMT' , config_flags%gmt , 1 , ierr )
642	CALL wrf_put_dom_ti_integer ( fid , 'JULYR' , config_flags%julyr , 1 , ierr )
643	CALL wrf_put_dom_ti_integer ( fid , 'JULDAY' , config_flags%julday , 1 , ierr )
644	#endif
645	ENDIF
646	#if (NMM_CORE == 1)
647	! MMINLU='USGS'
648	#endif
649	CALL wrf_put_dom_ti_integer ( fid , 'MAP_PROJ' , config_flags%map_proj , 1 , ierr )
650	IF(MMINLU(1:1) .EQ. " ")THEN
651	CALL wrf_put_dom_ti_char ( fid , 'MMINLU', " " , ierr )
652	ELSE
653	CALL wrf_put_dom_ti_char ( fid , 'MMINLU', TRIM(mminlu) , ierr )
654	END IF
655	call wrf_put_dom_ti_integer ( fid , 'NUM_LAND_CAT', config_flags%num_land_cat, 1, ierr)
656	CALL wrf_put_dom_ti_integer ( fid , 'ISWATER' , iswater , 1 , ierr )
657	CALL wrf_put_dom_ti_integer ( fid , 'ISLAKE' , islake , 1 , ierr )
658	! CALL wrf_put_dom_ti_integer ( fid , 'ISWATER' , config_flags%iswater , 1 , ierr )
659	CALL wrf_put_dom_ti_integer ( fid , 'ISICE' , config_flags%isice , 1 , ierr )
660	CALL wrf_put_dom_ti_integer ( fid , 'ISURBAN' , config_flags%isurban , 1 , ierr )
661	CALL wrf_put_dom_ti_integer ( fid , 'ISOILWATER' , config_flags%isoilwater , 1 , ierr )
662	! added these fields for restarting of moving nests, JM
663	!For HWRF: zhang
664	#ifdef HWRF
665	CALL wrf_put_dom_ti_integer ( fid , 'I_PARENT_START' , grid%i_parent_start , 1 , ierr )
666	CALL wrf_put_dom_ti_integer ( fid , 'J_PARENT_START' , grid%j_parent_start , 1 , ierr )
667	#else
668	CALL wrf_put_dom_ti_integer ( fid , 'I_PARENT_START' , config_flags%i_parent_start , 1 , ierr )
669	CALL wrf_put_dom_ti_integer ( fid , 'J_PARENT_START' , config_flags%j_parent_start , 1 , ierr )
670	#endif
671
672	IF ( switch .EQ. boundary_only ) THEN
673	CALL WRFU_TimeIntervalSet( bdy_increment, S=NINT(config_flags%bdyfrq),rc=rc)
674	next_time = currentTime + bdy_increment
675	CALL wrf_timetoa ( next_time, next_datestr )
676	CALL wrf_put_dom_td_char ( fid , 'THISBDYTIME' , current_date(1:19), current_date(1:19), ierr )
677	CALL wrf_put_dom_td_char ( fid , 'NEXTBDYTIME' , current_date(1:19), next_datestr(1:19), ierr )
678	ENDIF
679
680	! added grib2-specific metadata: Todd Hutchinson 8/21/2005
681	IF ( use_package( io_form ) == IO_GRIB2 ) THEN
682	CALL wrf_put_dom_ti_integer ( fid , 'BACKGROUND_PROC_ID' , config_flags%background_proc_id , 1 , ierr )
683	CALL wrf_put_dom_ti_integer ( fid , 'FORECAST_PROC_ID' , config_flags%forecast_proc_id , 1 , ierr )
684	CALL wrf_put_dom_ti_integer ( fid , 'PRODUCTION_STATUS' , config_flags%production_status , 1 , ierr )
685	CALL wrf_put_dom_ti_integer ( fid , 'COMPRESSION' , config_flags%compression , 1 , ierr )
686	ENDIF
687
688	#if (EM_CORE == 1)
689	save_topo_orig = grid%save_topo_from_real
690
691	! todo jm
692	IF ( (first_history .LE. switch .AND. switch .LE. last_history ) .OR. &
693	( (switch .EQ. input_only) .AND. (program_name(1:7) .NE. 'REAL_EM') ) .OR. &
694	( switch .EQ. restart_only ) ) THEN
695
696	! This flag sets the switch which defines the topography as the original
697	! generated by real.exe. The "zero" value means that for the WRF model
698	! output, the topography has been modified. All output from the ARW
699	! WRF model has this flag set. However, to allow nests to still be
700	! instantiated after a parent does IO, and to allow that nest domain
701	! to have the topo adjusted, we save the incoming value of the save_topo
702	! flag.
703
704	grid%save_topo_from_real=0
705	ENDIF
706	#endif
707
708	IF ( (first_input .LE. switch .AND. switch .LE. last_input) .OR. &
709	(first_history .LE. switch .AND. switch .LE. last_history ) .OR. &
710	switch .EQ. restart_only ) THEN
711	newswitch = switch
712	p => grid%head_statevars%next
713	DO WHILE ( ASSOCIATED( p ) )
714	IF ( p%ProcOrient .NE. 'X' .AND. p%ProcOrient .NE. 'Y' ) THEN ! no I/O for xposed variables
715	IF ( p%Ndim .EQ. 0 ) THEN
716	IF ((p%Restart.AND.switch.EQ.restart_only).OR.on_stream(p%streams,newswitch)) THEN
717	IF ( in_use_for_config(grid%id,TRIM(p%VarName)) ) THEN
718	dname = p%DataName
719	IF (p%Ntl.GT.0.AND.switch.NE.restart_only)dname=dname(1:len(TRIM(dname))-2)
720	memord = p%MemoryOrder
721	IF ( p%Type .EQ. 'r' ) THEN
722	CALL wrf_ext_write_field ( &
723	fid , & ! DataHandle
724	current_date(1:19) , & ! DateStr
725	TRIM(p%DataName) , & ! Data Name
726	p%rfield_0d , & ! Field
727	WRF_FLOAT , & ! FieldType
728	grid%communicator , & ! Comm
729	grid%iocommunicator , & ! Comm
730	grid%domdesc , & ! Comm
731	grid%bdy_mask , & ! bdy_mask
732	dryrun , & ! flag
733	'0' , & ! MemoryOrder
734	'' , & ! Stagger
735	'' , & ! Dimname 1
736	'' , & ! Dimname 2
737	'' , & ! Dimname 3
738	TRIM(p%Description) , & ! Desc
739	TRIM(p%Units) , & ! Units
740	__FILE__ // ' writing 0d real ' // TRIM(p%VarName) , & ! Debug message
741	1 , 1 , 1 , 1 , 1 , 1 , &
742	1 , 1 , 1 , 1 , 1 , 1 , &
743	1 , 1 , 1 , 1 , 1 , 1 , &
744	ierr )
745	ELSE IF ( p%Type .EQ. 'd' ) THEN
746	CALL wrf_ext_write_field ( &
747	fid , & ! DataHandle
748	current_date(1:19) , & ! DateStr
749	TRIM(p%DataName) , & ! Data Name
750	p%dfield_0d , & ! Field
751	WRF_DOUBLE , & ! FieldType
752	grid%communicator , & ! Comm
753	grid%iocommunicator , & ! Comm
754	grid%domdesc , & ! Comm
755	grid%bdy_mask , & ! bdy_mask
756	dryrun , & ! flag
757	'0' , & ! MemoryOrder
758	'' , & ! Stagger
759	'' , & ! Dimname 1
760	'' , & ! Dimname 2
761	'' , & ! Dimname 3
762	TRIM(p%Description) , & ! Desc
763	TRIM(p%Units) , & ! Units
764	__FILE__ // ' writing 0d double ' // TRIM(p%VarName) , & ! Debug message
765	1 , 1 , 1 , 1 , 1 , 1 , &
766	1 , 1 , 1 , 1 , 1 , 1 , &
767	1 , 1 , 1 , 1 , 1 , 1 , &
768	ierr )
769	ELSE IF ( p%Type .EQ. 'i' ) THEN
770	CALL wrf_ext_write_field ( &
771	fid , & ! DataHandle
772	current_date(1:19) , & ! DateStr
773	TRIM(p%DataName) , & ! Data Name
774	p%ifield_0d , & ! Field
775	WRF_INTEGER , & ! FieldType
776	grid%communicator , & ! Comm
777	grid%iocommunicator , & ! Comm
778	grid%domdesc , & ! Comm
779	grid%bdy_mask , & ! bdy_mask
780	dryrun , & ! flag
781	'0' , & ! MemoryOrder
782	'' , & ! Stagger
783	'' , & ! Dimname 1
784	'' , & ! Dimname 2
785	'' , & ! Dimname 3
786	TRIM(p%Description) , & ! Desc
787	TRIM(p%Units) , & ! Units
788	__FILE__ // ' writing 0d integer ' // TRIM(p%VarName) , & ! Debug message
789	1 , 1 , 1 , 1 , 1 , 1 , &
790	1 , 1 , 1 , 1 , 1 , 1 , &
791	1 , 1 , 1 , 1 , 1 , 1 , &
792	ierr )
793	ELSE IF ( p%Type .EQ. 'l' ) THEN
794	CALL wrf_ext_write_field ( &
795	fid , & ! DataHandle
796	current_date(1:19) , & ! DateStr
797	TRIM(p%DataName) , & ! Data Name
798	p%lfield_0d , & ! Field
799	WRF_LOGICAL , & ! FieldType
800	grid%communicator , & ! Comm
801	grid%iocommunicator , & ! Comm
802	grid%domdesc , & ! Comm
803	grid%bdy_mask , & ! bdy_mask
804	dryrun , & ! flag
805	'0' , & ! MemoryOrder
806	'' , & ! Stagger
807	'' , & ! Dimname 1
808	'' , & ! Dimname 2
809	'' , & ! Dimname 3
810	TRIM(p%Description) , & ! Desc
811	TRIM(p%Units) , & ! Units
812	__FILE__ // ' writing 0d logical ' // TRIM(p%VarName) , & ! Debug message
813	1 , 1 , 1 , 1 , 1 , 1 , &
814	1 , 1 , 1 , 1 , 1 , 1 , &
815	1 , 1 , 1 , 1 , 1 , 1 , &
816	ierr )
817	ENDIF
818	ENDIF
819	ENDIF
820	ELSE IF ( p%Ndim .EQ. 1 ) THEN
821	IF ((p%Restart.AND.switch.EQ.restart_only).OR.on_stream(p%streams,newswitch)) THEN
822	IF ( in_use_for_config(grid%id,TRIM(p%VarName)) ) THEN
823	IF (switch.EQ.restart_only.OR.p%Ntl/100.EQ.mod(p%Ntl,100)) THEN
824	dname = p%DataName
825	IF (p%Ntl.GT.0.AND.switch.NE.restart_only)dname=dname(1:len(TRIM(dname))-2)
826	memord = p%MemoryOrder
827	IF ( p%Type .EQ. 'r' ) THEN
828	CALL wrf_ext_write_field ( &
829	fid , & ! DataHandle
830	current_date(1:19) , & ! DateStr
831	TRIM(dname) , & ! Data Name
832	p%rfield_1d , & ! Field
833	WRF_FLOAT , & ! FieldType
834	grid%communicator , & ! Comm
835	grid%iocommunicator , & ! Comm
836	grid%domdesc , & ! Comm
837	grid%bdy_mask , & ! bdy_mask
838	dryrun , & ! flag
839	TRIM(memord) , & ! MemoryOrder
840	TRIM(p%Stagger) , & ! Stagger
841	TRIM(p%dimname1) , & ! Dimname 1
842	TRIM(p%dimname2) , & ! Dimname 2
843	TRIM(p%dimname3) , & ! Dimname 3
844	TRIM(p%Description) , & ! Desc
845	TRIM(p%Units) , & ! Units
846	__FILE__ // ' writing 1d real ' // TRIM(p%VarName) , & ! Debug message
847	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
848	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
849	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
850	ierr )
851	ELSE IF ( p%Type .EQ. 'd' ) THEN
852	CALL wrf_ext_write_field ( &
853	fid , & ! DataHandle
854	current_date(1:19) , & ! DateStr
855	TRIM(dname) , & ! Data Name
856	p%dfield_1d , & ! Field
857	WRF_DOUBLE , & ! FieldType
858	grid%communicator , & ! Comm
859	grid%iocommunicator , & ! Comm
860	grid%domdesc , & ! Comm
861	grid%bdy_mask , & ! bdy_mask
862	dryrun , & ! flag
863	TRIM(memord) , & ! MemoryOrder
864	TRIM(p%Stagger) , & ! Stagger
865	TRIM(p%dimname1) , & ! Dimname 1
866	TRIM(p%dimname2) , & ! Dimname 2
867	TRIM(p%dimname3) , & ! Dimname 3
868	TRIM(p%Description) , & ! Desc
869	TRIM(p%Units) , & ! Units
870	__FILE__ // ' writing 1d double ' // TRIM(p%VarName) , & ! Debug message
871	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
872	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
873	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
874	ierr )
875	ELSE IF ( p%Type .EQ. 'i' ) THEN
876	CALL wrf_ext_write_field ( &
877	fid , & ! DataHandle
878	current_date(1:19) , & ! DateStr
879	TRIM(dname) , & ! Data Name
880	p%ifield_1d , & ! Field
881	WRF_INTEGER , & ! FieldType
882	grid%communicator , & ! Comm
883	grid%iocommunicator , & ! Comm
884	grid%domdesc , & ! Comm
885	grid%bdy_mask , & ! bdy_mask
886	dryrun , & ! flag
887	TRIM(memord) , & ! MemoryOrder
888	TRIM(p%Stagger) , & ! Stagger
889	TRIM(p%dimname1) , & ! Dimname 1
890	TRIM(p%dimname2) , & ! Dimname 2
891	TRIM(p%dimname3) , & ! Dimname 3
892	TRIM(p%Description) , & ! Desc
893	TRIM(p%Units) , & ! Units
894	__FILE__ // ' writing 1d integer ' // TRIM(p%VarName) , & ! Debug message
895	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
896	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
897	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
898	ierr )
899	ELSE IF ( p%Type .EQ. 'l' ) THEN
900	CALL wrf_ext_write_field ( &
901	fid , & ! DataHandle
902	current_date(1:19) , & ! DateStr
903	TRIM(dname) , & ! Data Name
904	p%lfield_1d , & ! Field
905	WRF_LOGICAL , & ! FieldType
906	grid%communicator , & ! Comm
907	grid%iocommunicator , & ! Comm
908	grid%domdesc , & ! Comm
909	grid%bdy_mask , & ! bdy_mask
910	dryrun , & ! flag
911	TRIM(memord) , & ! MemoryOrder
912	TRIM(p%Stagger) , & ! Stagger
913	TRIM(p%dimname1) , & ! Dimname 1
914	TRIM(p%dimname2) , & ! Dimname 2
915	TRIM(p%dimname3) , & ! Dimname 3
916	TRIM(p%Description) , & ! Desc
917	TRIM(p%Units) , & ! Units
918	__FILE__ // ' writing 1d logical ' // TRIM(p%VarName) , & ! Debug message
919	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
920	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
921	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
922	ierr )
923	ENDIF
924	ENDIF
925	ENDIF
926	ENDIF
927	ELSE IF ( p%Ndim .EQ. 2 ) THEN
928	IF ((p%Restart.AND.switch.EQ.restart_only).OR.on_stream(p%streams,newswitch)) THEN
929	IF ( in_use_for_config(grid%id,TRIM(p%VarName)) .AND. &
930	( .NOT. p%subgrid_x .OR. (p%subgrid_x .AND. grid%sr_x .GT. 0) ) .AND. &
931	( .NOT. p%subgrid_y .OR. (p%subgrid_y .AND. grid%sr_y .GT. 0) ) &
932	) THEN
933	IF (switch.EQ.restart_only.OR.p%Ntl/100.EQ.mod(p%Ntl,100)) THEN
934	dname = p%DataName
935	IF (p%Ntl.GT.0.AND.switch.NE.restart_only)dname=dname(1:len(TRIM(dname))-2)
936	memord = p%MemoryOrder
937	IF ( p%Type .EQ. 'r' ) THEN
938	CALL wrf_ext_write_field ( &
939	fid , & ! DataHandle
940	current_date(1:19) , & ! DateStr
941	TRIM(dname) , & ! Data Name
942	p%rfield_2d , & ! Field
943	WRF_FLOAT , & ! FieldType
944	grid%communicator , & ! Comm
945	grid%iocommunicator , & ! Comm
946	grid%domdesc , & ! Comm
947	grid%bdy_mask , & ! bdy_mask
948	dryrun , & ! flag
949	TRIM(memord) , & ! MemoryOrder
950	TRIM(p%Stagger) , & ! Stagger
951	TRIM(p%dimname1) , & ! Dimname 1
952	TRIM(p%dimname2) , & ! Dimname 2
953	TRIM(p%dimname3) , & ! Dimname 3
954	TRIM(p%Description) , & ! Desc
955	TRIM(p%Units) , & ! Units
956	__FILE__ // ' writing 2d real ' // TRIM(p%VarName) , & ! Debug message
957	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
958	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
959	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
960	ierr )
961	ELSE IF ( p%Type .EQ. 'd' ) THEN
962	CALL wrf_ext_write_field ( &
963	fid , & ! DataHandle
964	current_date(1:19) , & ! DateStr
965	TRIM(dname) , & ! Data Name
966	p%dfield_2d , & ! Field
967	WRF_DOUBLE , & ! FieldType
968	grid%communicator , & ! Comm
969	grid%iocommunicator , & ! Comm
970	grid%domdesc , & ! Comm
971	grid%bdy_mask , & ! bdy_mask
972	dryrun , & ! flag
973	TRIM(memord) , & ! MemoryOrder
974	TRIM(p%Stagger) , & ! Stagger
975	TRIM(p%dimname1) , & ! Dimname 1
976	TRIM(p%dimname2) , & ! Dimname 2
977	TRIM(p%dimname3) , & ! Dimname 3
978	TRIM(p%Description) , & ! Desc
979	TRIM(p%Units) , & ! Units
980	__FILE__ // ' writing 2d double ' // TRIM(p%VarName) , & ! Debug message
981	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
982	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
983	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
984	ierr )
985	ELSE IF ( p%Type .EQ. 'i' ) THEN
986	CALL wrf_ext_write_field ( &
987	fid , & ! DataHandle
988	current_date(1:19) , & ! DateStr
989	TRIM(dname) , & ! Data Name
990	p%ifield_2d , & ! Field
991	WRF_INTEGER , & ! FieldType
992	grid%communicator , & ! Comm
993	grid%iocommunicator , & ! Comm
994	grid%domdesc , & ! Comm
995	grid%bdy_mask , & ! bdy_mask
996	dryrun , & ! flag
997	TRIM(memord) , & ! MemoryOrder
998	TRIM(p%Stagger) , & ! Stagger
999	TRIM(p%dimname1) , & ! Dimname 1
1000	TRIM(p%dimname2) , & ! Dimname 2
1001	TRIM(p%dimname3) , & ! Dimname 3
1002	TRIM(p%Description) , & ! Desc
1003	TRIM(p%Units) , & ! Units
1004	__FILE__ // ' writing 2d integer ' // TRIM(p%VarName) , & ! Debug message
1005	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1006	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1007	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1008	ierr )
1009	ELSE IF ( p%Type .EQ. 'l' ) THEN
1010	CALL wrf_ext_write_field ( &
1011	fid , & ! DataHandle
1012	current_date(1:19) , & ! DateStr
1013	TRIM(dname) , & ! Data Name
1014	p%lfield_2d , & ! Field
1015	WRF_LOGICAL , & ! FieldType
1016	grid%communicator , & ! Comm
1017	grid%iocommunicator , & ! Comm
1018	grid%domdesc , & ! Comm
1019	grid%bdy_mask , & ! bdy_mask
1020	dryrun , & ! flag
1021	TRIM(memord) , & ! MemoryOrder
1022	TRIM(p%Stagger) , & ! Stagger
1023	TRIM(p%dimname1) , & ! Dimname 1
1024	TRIM(p%dimname2) , & ! Dimname 2
1025	TRIM(p%dimname3) , & ! Dimname 3
1026	TRIM(p%Description) , & ! Desc
1027	TRIM(p%Units) , & ! Units
1028	__FILE__ // ' writing 2d logical ' // TRIM(p%VarName) , & ! Debug message
1029	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1030	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1031	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1032	ierr )
1033	ENDIF
1034	ENDIF
1035	ENDIF
1036	ENDIF
1037	ELSE IF ( p%Ndim .EQ. 3 ) THEN
1038	IF ((p%Restart.AND.switch.EQ.restart_only).OR.on_stream(p%streams,newswitch)) THEN
1039	IF ( in_use_for_config(grid%id,TRIM(p%VarName)) .AND. &
1040	( .NOT. p%subgrid_x .OR. (p%subgrid_x .AND. grid%sr_x .GT. 0) ) .AND. &
1041	( .NOT. p%subgrid_y .OR. (p%subgrid_y .AND. grid%sr_y .GT. 0) ) &
1042	) THEN
1043	IF (switch.EQ.restart_only.OR.p%Ntl/100.EQ.mod(p%Ntl,100)) THEN
1044	dname = p%DataName
1045	IF (p%Ntl.GT.0.AND.switch.NE.restart_only)dname=dname(1:len(TRIM(dname))-2)
1046	memord = p%MemoryOrder
1047	IF ( p%Type .EQ. 'r' ) THEN
1048	CALL wrf_ext_write_field ( &
1049	fid , & ! DataHandle
1050	current_date(1:19) , & ! DateStr
1051	TRIM(dname) , & ! Data Name
1052	p%rfield_3d , & ! Field
1053	WRF_FLOAT , & ! FieldType
1054	grid%communicator , & ! Comm
1055	grid%iocommunicator , & ! Comm
1056	grid%domdesc , & ! Comm
1057	grid%bdy_mask , & ! bdy_mask
1058	dryrun , & ! flag
1059	TRIM(memord) , & ! MemoryOrder
1060	TRIM(p%Stagger) , & ! Stagger
1061	TRIM(p%dimname1) , & ! Dimname 1
1062	TRIM(p%dimname2) , & ! Dimname 2
1063	TRIM(p%dimname3) , & ! Dimname 3
1064	TRIM(p%Description) , & ! Desc
1065	TRIM(p%Units) , & ! Units
1066	__FILE__ // ' writing 3d real ' // TRIM(p%VarName) , & ! Debug message
1067	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1068	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1069	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1070	ierr )
1071	ELSE IF ( p%Type .EQ. 'd' ) THEN
1072	CALL wrf_ext_write_field ( &
1073	fid , & ! DataHandle
1074	current_date(1:19) , & ! DateStr
1075	TRIM(dname) , & ! Data Name
1076	p%dfield_3d , & ! Field
1077	WRF_DOUBLE , & ! FieldType
1078	grid%communicator , & ! Comm
1079	grid%iocommunicator , & ! Comm
1080	grid%domdesc , & ! Comm
1081	grid%bdy_mask , & ! bdy_mask
1082	dryrun , & ! flag
1083	TRIM(memord) , & ! MemoryOrder
1084	TRIM(p%Stagger) , & ! Stagger
1085	TRIM(p%dimname1) , & ! Dimname 1
1086	TRIM(p%dimname2) , & ! Dimname 2
1087	TRIM(p%dimname3) , & ! Dimname 3
1088	TRIM(p%Description) , & ! Desc
1089	TRIM(p%Units) , & ! Units
1090	__FILE__ // ' writing 3d double ' // TRIM(p%VarName) , & ! Debug message
1091	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1092	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1093	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1094	ierr )
1095	ELSE IF ( p%Type .EQ. 'i' ) THEN
1096	CALL wrf_ext_write_field ( &
1097	fid , & ! DataHandle
1098	current_date(1:19) , & ! DateStr
1099	TRIM(dname) , & ! Data Name
1100	p%ifield_3d , & ! Field
1101	WRF_INTEGER , & ! FieldType
1102	grid%communicator , & ! Comm
1103	grid%iocommunicator , & ! Comm
1104	grid%domdesc , & ! Comm
1105	grid%bdy_mask , & ! bdy_mask
1106	dryrun , & ! flag
1107	TRIM(memord) , & ! MemoryOrder
1108	TRIM(p%Stagger) , & ! Stagger
1109	TRIM(p%dimname1) , & ! Dimname 1
1110	TRIM(p%dimname2) , & ! Dimname 2
1111	TRIM(p%dimname3) , & ! Dimname 3
1112	TRIM(p%Description) , & ! Desc
1113	TRIM(p%Units) , & ! Units
1114	__FILE__ // ' writing 3d integer ' // TRIM(p%VarName) , & ! Debug message
1115	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1116	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1117	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1118	ierr )
1119	! NOTE no io on logical arrays greater than 2d
1120	ENDIF
1121	ENDIF
1122	ENDIF
1123	ENDIF
1124	ELSE IF ( p%Ndim .EQ. 4 .AND. p%scalar_array ) THEN
1125	IF (switch.EQ.restart_only.OR.p%Ntl/100.EQ.mod(p%Ntl,100)) THEN
1126	! Use a different write routine, wrf_ext_write_field_arr, and pass in the
1127	! tracer indeces so that p%rfield_4d can be passsed in without arguments,
1128	! avoiding the possiblity of a copy-in/copy-out problem for some compilers.
1129	! JM 20091208
1130	DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id)
1131	IF ((p%Restart.AND.switch.EQ.restart_only).OR.on_stream(p%streams_table(grid%id,itrace)%stream,newswitch)) THEN
1132	dname = p%dname_table( grid%id, itrace )
1133	IF (p%Ntl.GT.0.AND.switch.NE.restart_only)dname=dname(1:len(TRIM(dname))-2)
1134	memord = p%MemoryOrder
1135	IF ( p%Type .EQ. 'r' ) THEN
1136	CALL wrf_ext_write_field_arr ( &
1137	fid , & ! DataHandle
1138	current_date(1:19) , & ! DateStr
1139	TRIM(p%dname_table( grid%id, itrace )) , & ! Data Name
1140	p%rfield_4d , & ! Field
1141	itrace, 1, 1, 1 , & ! see comment above
1142	1, 1, 1 , & ! see comment above
1143	RWORDSIZE , &
1144	WRF_FLOAT , & ! FieldType
1145	grid%communicator , & ! Comm
1146	grid%iocommunicator , & ! Comm
1147	grid%domdesc , & ! Comm
1148	grid%bdy_mask , & ! bdy_mask
1149	dryrun , & ! flag
1150	TRIM(memord) , & ! MemoryOrder
1151	TRIM(p%Stagger) , & ! Stagger
1152	TRIM(p%dimname1) , & ! Dimname 1
1153	TRIM(p%dimname2) , & ! Dimname 2
1154	TRIM(p%dimname3) , & ! Dimname 3
1155	TRIM(p%desc_table( grid%id, itrace)) , & ! Desc
1156	TRIM(p%units_table( grid%id, itrace)) , & ! Units
1157	__FILE__ // ' writing 4d real ' // TRIM(p%dname_table(grid%id,itrace)) , & ! Debug message
1158	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1159	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1160	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1161	ierr )
1162	ELSE IF ( p%Type .EQ. 'd' ) THEN
1163	CALL wrf_ext_write_field_arr ( &
1164	fid , & ! DataHandle
1165	current_date(1:19) , & ! DateStr
1166	TRIM(p%dname_table( grid%id, itrace )) , & ! Data Name
1167	p%dfield_4d , & ! Field
1168	itrace, 1, 1, 1 , & ! see comment above
1169	1, 1, 1 , & ! see comment above
1170	DWORDSIZE , &
1171	WRF_DOUBLE , & ! FieldType
1172	grid%communicator , & ! Comm
1173	grid%iocommunicator , & ! Comm
1174	grid%domdesc , & ! Comm
1175	grid%bdy_mask , & ! bdy_mask
1176	dryrun , & ! flag
1177	TRIM(memord) , & ! MemoryOrder
1178	TRIM(p%Stagger) , & ! Stagger
1179	TRIM(p%dimname1) , & ! Dimname 1
1180	TRIM(p%dimname2) , & ! Dimname 2
1181	TRIM(p%dimname3) , & ! Dimname 3
1182	TRIM(p%desc_table( grid%id, itrace)) , & ! Desc
1183	TRIM(p%units_table( grid%id, itrace)) , & ! Units
1184	__FILE__ // ' writing 4d double ' // TRIM(p%dname_table(grid%id,itrace)) , & ! Debug message
1185	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1186	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1187	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1188	ierr )
1189	ELSE IF ( p%Type .EQ. 'i' ) THEN
1190	CALL wrf_ext_write_field_arr ( &
1191	fid , & ! DataHandle
1192	current_date(1:19) , & ! DateStr
1193	TRIM(p%dname_table( grid%id, itrace )) , & ! Data Name
1194	p%ifield_4d , & ! Field
1195	itrace, 1, 1, 1 , & ! see comment above
1196	1, 1, 1 , & ! see comment above
1197	IWORDSIZE , &
1198	WRF_INTEGER , & ! FieldType
1199	grid%communicator , & ! Comm
1200	grid%iocommunicator , & ! Comm
1201	grid%domdesc , & ! Comm
1202	grid%bdy_mask , & ! bdy_mask
1203	dryrun , & ! flag
1204	TRIM(memord) , & ! MemoryOrder
1205	TRIM(p%Stagger) , & ! Stagger
1206	TRIM(p%dimname1) , & ! Dimname 1
1207	TRIM(p%dimname2) , & ! Dimname 2
1208	TRIM(p%dimname3) , & ! Dimname 3
1209	TRIM(p%desc_table( grid%id, itrace)) , & ! Desc
1210	TRIM(p%units_table( grid%id, itrace)) , & ! Units
1211	__FILE__ // ' writing 4d integer ' // TRIM(p%dname_table(grid%id,itrace)) , & ! Debug message
1212	p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , &
1213	p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , &
1214	p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , &
1215	ierr )
1216	ENDIF
1217	ENDIF
1218	ENDDO ! loop over tracers
1219	ENDIF ! if-then-else over dim
1220	ENDIF
1221	ENDIF
1222	p => p%next
1223	ENDDO
1224	ELSE
1225	IF ( switch .EQ. boundary_only ) THEN
1226	CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_bdyout.inc' )
1227	CALL wrf_bdyout( fid , grid , config_flags, switch, dryrun, ierr )
1228	ENDIF
1229	ENDIF
1230
1231	IF ( switch .EQ. history_only ) THEN
1232	IF (adjust) THEN
1233	current_date = current_date_save
1234	ENDIF
1235	ENDIF
1236
1237	#if (EM_CORE == 1)
1238	grid%save_topo_from_real = save_topo_orig
1239	#endif
1240
1241	IF ( .NOT. dryrun ) THEN
1242	CALL wrf_debug ( 300 , 'output_wrf: calling wrf_iosync ' )
1243	CALL wrf_iosync ( fid , ierr )
1244	CALL wrf_debug ( 300 , 'output_wrf: back from wrf_iosync ' )
1245	ENDIF
1246
1247	WRITE(wrf_err_message,*)'output_wrf: end, fid = ',fid
1248	CALL wrf_debug( 300 , wrf_err_message )
1249
1250	RETURN
1251	END SUBROUTINE output_wrf
1252
1253	SUBROUTINE traverse_statevars_debug (s,l)
1254	USE module_domain
1255	IMPLICIT NONE
1256	character()s
1257	integer l, itrace
1258	TYPE( fieldlist ), POINTER :: p
1259	p => head_grid%head_statevars%next
1260	! write(0,*)'traverse_statevars_debug called ',TRIM(s),' ',l
1261	DO WHILE ( ASSOCIATED( p ) )
1262	! IF ( p%Ndim .EQ. 4 .AND. p%scalar_array ) THEN
1263	! DO itrace = PARAM_FIRST_SCALAR , p%num_table(1)
1264	!write(0,*)TRIM(s),l, itrace, p%streams_table(1,itrace)%stream
1265	! ENDDO
1266	! ENDIF
1267	! if ( TRIM(p%VarName) .EQ. 'store_rand' .OR. TRIM(p%VarName) .EQ. 'STORE_RAND' ) then
1268	! write(0,*)'traverse_statevars_debug sees ',TRIM(p%VarName),' >',p%Type,'<'
1269	! endif
1270	p => p%next
1271	ENDDO
1272	RETURN
1273	END SUBROUTINE traverse_statevars_debug
1274

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

Download in other formats:

Original Format