Context Navigation

input_module.F90 @ 1068

Last change on this file since 1068 was 207, checked in by aslmd, 14 years ago
MESOSCALE: A GENERAL CLEAN-UP FOLLOWING UPDATING THE USER MANUAL. EVERYTHING ESSENTIAL IS IN MESOSCALE (much lighter than before). EVERYTHING FOR DEVELOPPERS OR EXPERTS IS IN MESOSCALE_DEV.
File size: 24.4 KB

Line
1	MODULE input_module
2
3	USE gridinfo_module
4	USE misc_definitions_module
5	USE module_debug
6	USE module_model_basics
7	USE queue_module
8	#ifdef IO_BINARY
9	USE module_internal_header_util
10	#endif
11
12
13	! WRF I/O API related variables
14	integer :: handle
15
16	type (queue) :: unit_desc
17	integer :: num_calls, iatts
18	character (len=200), dimension(200) :: catts
19
20	CONTAINS
21
22
23	SUBROUTINE input_init (file_number, istatus)
24
25	implicit none
26
27	#include "wrf_io_flags.h"
28	#include "wrf_status_codes.h"
29
30	! Arguments
31	integer, intent(in) :: file_number
32	integer, intent(out) :: istatus
33
34	! Local variables
35	character (len=128) :: input_fname
36
37	istatus = 0
38	CALL arw_ioinit(istatus)
39
40	istatus = 0
41	input_fname = ' '
42	input_fname = trim(input_file_names(file_number))
43	CALL arw_open_for_read(input_fname, handle, istatus)
44
45	CALL q_init(unit_desc)
46
47	num_calls = 0
48
49	END SUBROUTINE input_init
50
51
52	SUBROUTINE read_next_field (domain_start, domain_end, &
53	cname, cunits, cdesc, memorder, &
54	stagger, dimnames, real_array, valid_date, istatus)
55
56	implicit none
57
58	#include "wrf_io_flags.h"
59	#include "wrf_status_codes.h"
60
61	! Arguments
62	integer, dimension(3) :: domain_start, domain_end
63	real, pointer, dimension(:,:,:) :: real_array
64	character (len=*), intent(out) :: cname, memorder, stagger, cunits, cdesc
65	character (len=128), dimension(3) :: dimnames
66	integer, intent(inout) :: istatus
67
68	! Local variables
69	integer :: ndim, wrftype
70	real, pointer, dimension(:,:,:) :: real_domain
71	character (len=19) :: valid_date
72	type (q_data) :: qd
73
74
75	num_calls = num_calls + 1
76	domain_start = 1
77	domain_end = 1
78
79	#ifdef IO_NETCDF
80	IF (io_form_input == NETCDF) THEN
81	CALL arw_get_next_var(handle, cname, istatus)
82	END IF
83	#endif
84	if (istatus /= 0) return
85
86	istatus = 0
87	CALL arw_get_var_info(handle, cname, ndim, memorder, stagger, cdesc, cunits, domain_start, domain_end, wrftype, istatus)
88	if (istatus /= 0) return
89	if (ndim == 0) return
90	if (ndim /= 3) then
91	domain_start(3) = 1
92	domain_end(3) = 1
93	end if
94
95
96	IF ( ASSOCIATED(real_array) ) DEALLOCATE(real_array)
97	IF ( ASSOCIATED(real_domain) ) DEALLOCATE(real_domain)
98	ALLOCATE(real_domain(domain_end(1), domain_end(2), domain_end(3)))
99	CALL arw_read_field(handle, valid_date, cname, real_domain, wrftype, &
100	memorder, stagger, dimnames, domain_start, domain_end, istatus)
101
102
103	if (io_form_input == BINARY) then
104	qd = q_remove(unit_desc)
105	cunits = qd%units
106	cdesc = qd%description
107	else
108
109	#ifdef IO_NETCDF
110	if (io_form_input == NETCDF) then
111	CALL ext_ncd_get_var_ti_char(handle, 'units', cname, cunits, istatus)
112	CALL ext_ncd_get_var_ti_char(handle, 'description', cname, cdesc, istatus)
113	end if
114	#endif
115	!!#ifdef IO_GRIB1
116	!! if (io_form_input == GRIB1) then
117	!! CALL ext_gr1_get_var_ti_char(handle, 'units', cname, cunits, istatus)
118	!! CALL ext_gr1_get_var_ti_char(handle, 'description', cname, cdesc, istatus)
119	!! end if
120	!!#endif
121
122	end if
123
124	IF (len_trim(cdesc) == 1 ) cdesc = cname !!! Because .ctl must have a description
125
126	real_array => real_domain
127
128	END SUBROUTINE read_next_field
129
130	SUBROUTINE read_spec_field (domain_start, domain_end, cname, wrftype, memorder, &
131	stagger, dimnames, real_array, valid_date, istatus)
132
133	implicit none
134
135	#include "wrf_io_flags.h"
136	#include "wrf_status_codes.h"
137
138	! Arguments
139	integer, dimension(3) :: domain_start, domain_end
140	real, pointer, dimension(:,:,:) :: real_array
141	character (len=*), intent(in) :: memorder, stagger
142	character (len=*), intent(in) :: cname
143	character (len=128), dimension(3) :: dimnames
144	integer, intent(inout) :: istatus
145
146	! Local variables
147	integer :: ndim, wrftype
148	real, pointer, dimension(:,:,:) :: real_domain
149	character (len=19) :: valid_date
150	type (q_data) :: qd
151
152
153	istatus = 0
154
155	IF ( ASSOCIATED(real_domain) ) DEALLOCATE(real_domain)
156	IF ( ASSOCIATED(real_array) ) DEALLOCATE(real_array)
157
158	!! IF ( ASSOCIATED(real_domain) ) DEALLOCATE(real_domain)
159	! nullify(real_domain) ! Bug fix
160	! IF ( ASSOCIATED(real_array) ) DEALLOCATE(real_array)
161
162
163	ALLOCATE(real_domain(domain_end(1), domain_end(2), domain_end(3)))
164	CALL arw_read_field(handle, valid_date, cname, real_domain, wrftype, &
165	memorder, stagger, dimnames, domain_start, domain_end, istatus)
166
167
168	real_array => real_domain
169
170	END SUBROUTINE read_spec_field
171
172
173	SUBROUTINE read_global_attrs ()
174
175	implicit none
176
177	! Local variables
178	integer :: dyn_opt
179	integer :: outcount, istatus
180	character (len=19) :: start_date
181	character (len=128) :: grid_type
182	character (len=128) :: cunits, cdesc, cstagger, mminlu
183	type (q_data) :: qd
184	real :: dum_r
185	integer :: dum_i
186
187	iatts = 0
188
189	iprogram = 8
190	CALL arw_get_gbl_att_char(handle, 'TITLE', title, istatus)
191	IF ( INDEX(title,'OUTPUT FROM WRF SI') /= 0 ) iprogram = 0 !! WRFSI output
192	IF (trim(title) == 'OUTPUT FROM GRIDGEN') iprogram = 1 !! geogrid output
193	IF (trim(title) == 'OUTPUT FROM METGRID') iprogram = 3 !! metgrid output
194	IF ( INDEX(title,'OUTPUT FROM REAL_EM') /= 0 ) iprogram = 6 !! real.exe output
195
196	CALL arw_get_gbl_att_char(handle, 'SIMULATION_START_DATE', start_date, istatus)
197	CALL arw_get_gbl_att_char(handle, 'GRIDTYPE', grid_type, istatus)
198	CALL arw_get_gbl_att_char(handle, 'MMINLU', mminlu, istatus)
199
200	!! Make sure we are working with the unstaggered values here
201	CALL arw_get_gbl_att_int_sca(handle, 'WEST-EAST_GRID_DIMENSION', west_east_dim, 1, outcount, istatus)
202	west_east_dim = west_east_dim - 1
203	CALL arw_get_gbl_att_int_sca(handle, 'SOUTH-NORTH_GRID_DIMENSION', south_north_dim, 1, outcount, istatus)
204	south_north_dim = south_north_dim - 1
205	CALL arw_get_gbl_att_int_sca(handle, 'BOTTOM-TOP_GRID_DIMENSION', bottom_top_dim, 1, outcount, istatus)
206	!!!!
207	!!!! fix to allow the use of ncrcat to reduce vertical levels number in wrfout input files
208	!!!!
209	include "../change_bottom_top_dim"
210	!!!!
211	!!!!
212	IF ( iprogram .le. 1 ) bottom_top_dim = 24 !!! Just to make room for the 3D datasets
213	IF ( iprogram .ge. 6 ) bottom_top_dim = bottom_top_dim - 1
214
215
216
217	CALL arw_get_gbl_att_int_sca(handle, 'DYN_OPT', dyn_opt, 1, outcount, istatus)
218	CALL arw_get_gbl_att_int_sca(handle, 'MAP_PROJ', map_proj, 1, outcount, istatus)
219	CALL arw_get_gbl_att_real_sca(handle, 'DX', dx, 1, outcount, istatus)
220	CALL arw_get_gbl_att_real_sca(handle, 'DY', dy, 1, outcount, istatus)
221	CALL arw_get_gbl_att_real_sca(handle, 'CEN_LAT', cen_lat, 1, outcount, istatus)
222	CALL arw_get_gbl_att_real_sca(handle, 'CEN_LON', cen_lon, 1, outcount, istatus)
223	CALL arw_get_gbl_att_real_sca(handle, 'TRUELAT1', truelat1, 1, outcount, istatus)
224	CALL arw_get_gbl_att_real_sca(handle, 'TRUELAT2', truelat2, 1, outcount, istatus)
225	CALL arw_get_gbl_att_real_sca(handle, 'MOAD_CEN_LAT', moad_cen_lat, 1, outcount, istatus)
226	CALL arw_get_gbl_att_real_sca(handle, 'STAND_LON', stand_lon, 1, outcount, istatus)
227	!!CALL arw_get_gbl_att_real_arr(handle, 'corner_lats', corner_lats, 16, outcount, istatus)
228	!!CALL arw_get_gbl_att_real_arr(handle, 'corner_lons', corner_lons, 16, outcount, istatus)
229
230	!!! Just needed for meta data in the .ctl file
231	!CALL arw_get_gbl_att_int_sca(handle, 'DYN_OPT', dum_i, 1, outcount, istatus)
232	!CALL arw_get_gbl_att_int_sca(handle, 'DIFF_OPT', dum_i, 1, outcount, istatus)
233	!CALL arw_get_gbl_att_int_sca(handle, 'KM_OPT', dum_i, 1, outcount, istatus)
234	!CALL arw_get_gbl_att_int_sca(handle, 'DAMP_OPT', dum_i, 1, outcount, istatus)
235	!CALL arw_get_gbl_att_real_sca(handle, 'KHDIF', dum_r, 1, outcount, istatus)
236	!CALL arw_get_gbl_att_real_sca(handle, 'KVDIF', dum_r, 1, outcount, istatus)
237	!CALL arw_get_gbl_att_int_sca(handle, 'MP_PHYSICS', dum_i, 1, outcount, istatus)
238	!CALL arw_get_gbl_att_int_sca(handle, 'RA_LW_PHYSICS', dum_i, 1, outcount, istatus)
239	!CALL arw_get_gbl_att_int_sca(handle, 'RA_SW_PHYSICS', dum_i, 1, outcount, istatus)
240	!CALL arw_get_gbl_att_int_sca(handle, 'SF_SFCLAY_PHYSICS', dum_i, 1, outcount, istatus)
241	!CALL arw_get_gbl_att_int_sca(handle, 'SF_SURFACE_PHYSICS', dum_i, 1, outcount, istatus)
242	!CALL arw_get_gbl_att_int_sca(handle, 'BL_PBL_PHYSICS', dum_i, 1, outcount, istatus)
243	!CALL arw_get_gbl_att_int_sca(handle, 'CU_PHYSICS', dum_i, 1, outcount, istatus)
244	!CALL arw_get_gbl_att_int_sca(handle, 'GRID_ID', dum_i, 1, outcount, istatus)
245	!CALL arw_get_gbl_att_int_sca(handle, 'PARENT_ID', dum_i, 1, outcount, istatus)
246	!CALL arw_get_gbl_att_int_sca(handle, 'I_PARENT_START', dum_i, 1, outcount, istatus)
247	!CALL arw_get_gbl_att_int_sca(handle, 'J_PARENT_START', dum_i, 1, outcount, istatus)
248	!CALL arw_get_gbl_att_int_sca(handle, 'PARENT_GRID_RATIO', dum_i, 1, outcount, istatus)
249	!CALL arw_get_gbl_att_real_sca(handle, 'DT', dum_r, 1, outcount, istatus)
250	!CALL arw_get_gbl_att_int_sca(handle, 'ISWATER', dum_i, 1, outcount, istatus)
251	!CALL arw_get_gbl_att_int_sca(handle, 'ISICE', dum_i, 1, outcount, istatus)
252	!CALL arw_get_gbl_att_int_sca(handle, 'ISURBAN', dum_i, 1, outcount, istatus)
253	!CALL arw_get_gbl_att_int_sca(handle, 'ISOILWATER', dum_i, 1, outcount, istatus)
254
255
256	END SUBROUTINE read_global_attrs
257
258
259	SUBROUTINE input_close()
260
261	implicit none
262
263	! Local variables
264	integer :: istatus
265
266	istatus = 0
267	#ifdef IO_BINARY
268	if (io_form_input == BINARY) then
269	CALL ext_int_ioclose(handle, istatus)
270	CALL ext_int_ioexit(istatus)
271	end if
272	#endif
273	#ifdef IO_NETCDF
274	if (io_form_input == NETCDF) then
275	CALL ext_ncd_ioclose(handle, istatus)
276	CALL ext_ncd_ioexit(istatus)
277	end if
278	#endif
279	#ifdef IO_GRIB1
280	if (io_form_input == GRIB1) then
281	CALL ext_gr1_ioclose(handle, istatus)
282	CALL ext_gr1_ioexit(istatus)
283	end if
284	#endif
285
286	CALL q_destroy(unit_desc)
287
288	END SUBROUTINE input_close
289	!------------------------------------------------------------------------------------------
290	!------------------------------------------------------------------------------------------
291	!------------------------------------------------------------------------------------------
292
293	SUBROUTINE arw_ioinit (istatus)
294
295	implicit none
296
297	! Arguments
298	integer :: istatus
299
300	#ifdef IO_BINARY
301	if (io_form_input == BINARY) CALL ext_int_ioinit('sysdep info', istatus)
302	#endif
303	#ifdef IO_NETCDF
304	if (io_form_input == NETCDF) CALL ext_ncd_ioinit('sysdep info', istatus)
305	#endif
306	#ifdef IO_GRIB1
307	if (io_form_input == GRIB1) CALL ext_gr1_ioinit('sysdep info', istatus)
308	#endif
309	CALL mprintf((istatus /= 0),ERROR,'Error in ext_pkg_ioinit')
310
311	END SUBROUTINE arw_ioinit
312
313	!------------------------------------------------------------------------------------------
314
315	SUBROUTINE arw_open_for_read (input_fname, handle, istatus)
316
317	implicit none
318
319	! Arguments
320	integer :: handle, istatus
321	character (len=128) :: input_fname
322
323	#ifdef IO_BINARY
324	if (io_form_input == BINARY) &
325	CALL ext_int_open_for_read(trim(input_fname), 1, 1, 'sysdep info', handle, istatus)
326	#endif
327	#ifdef IO_NETCDF
328	if (io_form_input == NETCDF) &
329	CALL ext_ncd_open_for_read(trim(input_fname), 1, 1, 'sysdep info', handle, istatus)
330	#endif
331	#ifdef IO_GRIB1
332	if (io_form_input == GRIB1) &
333	CALL ext_gr1_open_for_read(trim(input_fname), 1, 1, 'sysdep info', handle, istatus)
334	#endif
335	CALL mprintf((istatus /= 0),ERROR,'Error in ext_pkg_open_for_read')
336
337	END SUBROUTINE arw_open_for_read
338
339	!------------------------------------------------------------------------------------------
340
341	SUBROUTINE arw_get_next_time (handle, datestr, istatus)
342
343	implicit none
344
345	! Arguments
346	integer :: handle, istatus
347	character (len=*) :: datestr
348
349
350	#ifdef IO_BINARY
351	if (io_form_input == BINARY) CALL ext_int_get_next_time(handle, datestr, istatus)
352	#endif
353	#ifdef IO_NETCDF
354	if (io_form_input == NETCDF) CALL ext_ncd_get_next_time(handle, datestr, istatus)
355	#endif
356	#ifdef IO_GRIB1
357	if (io_form_input == GRIB1) CALL ext_gr1_get_next_time(handle, datestr, istatus)
358	#endif
359	!!CALL mprintf((istatus /= 0),ERROR,'Error while reading next time .')
360
361	END SUBROUTINE arw_get_next_time
362
363	!------------------------------------------------------------------------------------------
364
365	SUBROUTINE arw_get_gbl_att_char (handle, att_string, att, istatus)
366
367	implicit none
368
369	! Arguments
370	integer :: handle, istatus
371	character() :: att_string
372	character (len=*) :: att
373
374
375	#ifdef IO_BINARY
376	if (io_form_input == BINARY) CALL ext_int_get_dom_ti_char(handle, att_string, att, istatus)
377	#endif
378	#ifdef IO_NETCDF
379	if (io_form_input == NETCDF) CALL ext_ncd_get_dom_ti_char(handle, att_string, att, istatus)
380	#endif
381	#ifdef IO_GRIB1
382	if (io_form_input == GRIB1) CALL ext_gr1_get_dom_ti_char(handle, att_string, att, istatus)
383	#endif
384	!!CALL mprintf((istatus /= 0),ERROR,'Error while reading domain global charachter attribute.')
385	IF ( istatus == 0 ) THEN
386	iatts = iatts + 1
387	WRITE(catts(iatts),'("@ global String comment ",A," = ",A)') trim(att_string), trim(att)
388	END IF
389
390	END SUBROUTINE arw_get_gbl_att_char
391
392	!------------------------------------------------------------------------------------------
393
394	SUBROUTINE arw_get_gbl_att_int_sca (handle, att_string, att, dim, outcount, istatus)
395
396	implicit none
397
398	! Arguments
399	integer :: handle, dim, outcount, istatus
400	character() :: att_string
401	integer :: att
402
403
404	#ifdef IO_BINARY
405	if (io_form_input == BINARY) CALL ext_int_get_dom_ti_integer(handle, att_string, att, dim, outcount, istatus)
406	#endif
407	#ifdef IO_NETCDF
408	if (io_form_input == NETCDF) CALL ext_ncd_get_dom_ti_integer(handle, att_string, att, dim, outcount, istatus)
409	#endif
410	#ifdef IO_GRIB1
411	if (io_form_input == GRIB1) CALL ext_gr1_get_dom_ti_integer(handle, att_string, att, dim, outcount, istatus)
412	#endif
413	!!CALL mprintf((istatus /= 0),ERROR,'Error while reading domain global integer attribute.')
414	IF ( istatus == 0 ) THEN
415	iatts = iatts + 1
416	WRITE(catts(iatts),'("@ global String comment ",A," = ",i5)') trim(att_string), att
417	END IF
418
419	END SUBROUTINE arw_get_gbl_att_int_sca
420
421	!------------------------------------------------------------------------------------------
422
423	SUBROUTINE arw_get_gbl_att_real_sca (handle, att_string, att, dim, outcount, istatus)
424
425	implicit none
426
427	! Arguments
428	integer :: handle, dim, outcount, istatus
429	character() :: att_string
430	real :: att
431
432
433	#ifdef IO_BINARY
434	if (io_form_input == BINARY) CALL ext_int_get_dom_ti_real(handle, att_string, att, dim, outcount, istatus)
435	#endif
436	#ifdef IO_NETCDF
437	if (io_form_input == NETCDF) CALL ext_ncd_get_dom_ti_real(handle, att_string, att, dim, outcount, istatus)
438	#endif
439	#ifdef IO_GRIB1
440	if (io_form_input == GRIB1) CALL ext_gr1_get_dom_ti_real(handle, att_string, att, dim, outcount, istatus)
441	#endif
442	!!CALL mprintf((istatus /= 0),ERROR,'Error while reading domain global real attribute.')
443	IF ( istatus == 0 ) THEN
444	iatts = iatts + 1
445	WRITE(catts(iatts),'("@ global String comment ",A," = ",f12.2)') trim(att_string), att
446	END IF
447
448	END SUBROUTINE arw_get_gbl_att_real_sca
449
450	!------------------------------------------------------------------------------------------
451
452	SUBROUTINE arw_get_gbl_att_real_arr (handle, att_string, att, dim, outcount, istatus)
453
454	implicit none
455
456	! Arguments
457	integer :: handle, dim, outcount, istatus
458	character() :: att_string
459	real, dimension(*) :: att
460
461
462	#ifdef IO_BINARY
463	if (io_form_input == BINARY) CALL ext_int_get_dom_ti_real(handle, att_string, att, dim, outcount, istatus)
464	#endif
465	#ifdef IO_NETCDF
466	if (io_form_input == NETCDF) CALL ext_ncd_get_dom_ti_real(handle, att_string, att, dim, outcount, istatus)
467	#endif
468	#ifdef IO_GRIB1
469	if (io_form_input == GRIB1) CALL ext_gr1_get_dom_ti_real(handle, att_string, att, dim, outcount, istatus)
470	#endif
471	CALL mprintf((istatus /= 0),ERROR,'Error while reading domain global real attribute.')
472
473	END SUBROUTINE arw_get_gbl_att_real_arr
474
475	!------------------------------------------------------------------------------------------
476
477	SUBROUTINE arw_get_next_var (handle, cname, istatus)
478
479	implicit none
480
481	! Arguments
482	integer :: handle, istatus
483	character() :: cname
484
485	#ifdef IO_BINARY
486	if (io_form_input == BINARY) CALL ext_int_get_next_var(handle, cname, istatus)
487	#endif
488	#ifdef IO_NETCDF
489	if (io_form_input == NETCDF) CALL ext_ncd_get_next_var(handle, cname, istatus)
490	#endif
491	#ifdef IO_GRIB1
492	if (io_form_input == GRIB1) CALL ext_gr1_get_next_var(handle, cname, istatus)
493	#endif
494
495	END SUBROUTINE arw_get_next_var
496
497	!------------------------------------------------------------------------------------------
498
499	SUBROUTINE arw_get_var_info (handle, cname, ndim, memorder, stagger, cdesc, cunits, domain_start, domain_end, wrftype, istatus)
500
501	implicit none
502
503	! Arguments
504	integer :: handle, istatus
505	integer :: ndim, wrftype
506	integer, dimension(3) :: domain_start, domain_end
507	character() :: cname, memorder, stagger, cdesc, cunits
508
509
510	cunits = ' '
511	cdesc = ' '
512
513
514	#ifdef IO_BINARY
515	if (io_form_input == BINARY) &
516	CALL ext_int_get_var_info(handle, cname, ndim, memorder, stagger, domain_start, domain_end, wrftype, istatus)
517	#endif
518	#ifdef IO_NETCDF
519	if (io_form_input == NETCDF) &
520	CALL ext_ncd_get_var_info(handle, cname, ndim, memorder, stagger, domain_start, domain_end, wrftype, istatus)
521	#endif
522	#ifdef IO_GRIB1
523	IF (io_form_input == GRIB1) THEN
524	10 read (13,'(i3,5x,A3,4x,A1,5x,A13,A48,A15)',END=999) wrftype, memorder, stagger, cname, cdesc, cunits
525	ndim = LEN_trim(memorder)
526	IF (iprogram .le. 1 .AND. ndim == 3 .AND. INDEX(memorder,'m') == 0) GOTO 10
527	IF (iprogram .le. 1 .AND. ndim == 1) GOTO 10
528	IF (iprogram == 8 .AND. INDEX(memorder,'g') /= 0) GOTO 10
529	IF ( LEN_trim(memorder) == 3 ) THEN
530	domain_end(1) = west_east_dim
531	domain_end(2) = south_north_dim
532	domain_end(3) = bottom_top_dim
533	IF (stagger(1:1) == "X") domain_end(1) = domain_end(1) + 1
534	IF (stagger(1:1) == "Y") domain_end(2) = domain_end(2) + 1
535	IF (iprogram .ge. 6 .AND. stagger(1:1) == "Z") domain_end(3) = domain_end(3) + 1
536	IF ( INDEX(memorder,'m') /= 0 ) domain_end(3) = 12
537	IF ( INDEX(memorder,'u') /= 0 ) domain_end(3) = 24
538	memorder = "XYZ"
539	ELSE IF ( LEN_trim(memorder) == 2 ) THEN
540	domain_end(1) = west_east_dim
541	domain_end(2) = south_north_dim
542	IF (stagger(1:1) == "X") domain_end(1) = domain_end(1) + 1
543	IF (stagger(1:1) == "Y") domain_end(2) = domain_end(2) + 1
544	memorder = "XY"
545	ELSE IF ( LEN_trim(memorder) == 1 ) THEN
546	domain_end(1) = bottom_top_dim
547	IF (iprogram .ge. 6 .AND. stagger(1:1) == "Z") domain_end(1) = domain_end(1) + 1
548	memorder = "Z"
549	END IF
550	END IF
551	#endif
552
553	CALL mprintf((istatus /= 0),ERROR,'In read_next_field(), problems with ext_pkg_get_var_info()')
554	RETURN
555	999 istatus = -1 !!! Reached end of file
556
557	END SUBROUTINE arw_get_var_info
558
559	!------------------------------------------------------------------------------------------
560
561	SUBROUTINE arw_read_field (handle, valid_date, cname, real_domain, wrftype, &
562	memorder, stagger, &
563	dimnames, domain_start, domain_end, istatus)
564
565	implicit none
566
567	! Arguments
568	integer :: handle, istatus
569	integer :: ndim, wrftype
570	integer, dimension(3) :: domain_start, domain_end
571	character() :: cname, memorder, stagger, valid_date
572	character (len=128), dimension(3) :: dimnames
573	real, pointer, dimension(:,:,:) :: real_domain
574	integer, pointer, dimension(:,:,:) :: int_domain
575
576	#include "wrf_io_flags.h"
577	#include "wrf_status_codes.h"
578
579
580	!!! caca
581	!print *, 'arw_read_field ', handle, valid_date, cname, wrftype, &
582	! memorder, stagger, &
583	! dimnames, domain_start, domain_end, istatus
584	!!! caca
585
586	if (wrftype == WRF_REAL) then
587	#ifdef IO_BINARY
588	if (io_form_input == BINARY) then
589	CALL ext_int_read_field(handle, valid_date, cname, real_domain, wrftype, &
590	1, 1, 0, memorder, stagger, &
591	dimnames, domain_start, domain_end, domain_start, domain_end, &
592	domain_start, domain_end, istatus)
593	end if
594	#endif
595	#ifdef IO_NETCDF
596	if (io_form_input == NETCDF) then
597	CALL ext_ncd_read_field(handle, valid_date, cname, real_domain, wrftype, &
598	1, 1, 0, memorder, stagger, &
599	dimnames, domain_start, domain_end, domain_start, domain_end, &
600	domain_start, domain_end, istatus)
601	end if
602	#endif
603	#ifdef IO_GRIB1
604	if (io_form_input == GRIB1) then
605	CALL ext_gr1_read_field(handle, valid_date, cname, real_domain, wrftype, &
606	1, 1, 0, memorder, stagger, &
607	dimnames, domain_start, domain_end, domain_start, domain_end, &
608	domain_start, domain_end, istatus)
609	end if
610	#endif
611	elseif (wrftype == WRF_INTEGER) then
612	allocate(int_domain(domain_start(1):domain_end(1), domain_start(2):domain_end(2), domain_start(3):domain_end(3)))
613	#ifdef IO_BINARY
614	if (io_form_input == BINARY) then
615	CALL ext_int_read_field(handle, valid_date, cname, int_domain, wrftype, &
616	1, 1, 0, memorder, stagger, &
617	dimnames, domain_start, domain_end, domain_start, domain_end, &
618	domain_start, domain_end, istatus)
619	end if
620	#endif
621	#ifdef IO_NETCDF
622	if (io_form_input == NETCDF) then
623	CALL ext_ncd_read_field(handle, valid_date, cname, int_domain, wrftype, &
624	1, 1, 0, memorder, stagger, &
625	dimnames, domain_start, domain_end, domain_start, domain_end, &
626	domain_start, domain_end, istatus)
627	end if
628	#endif
629	#ifdef IO_GRIB1
630	if (io_form_input == GRIB1) then
631	CALL ext_gr1_read_field(handle, valid_date, cname, int_domain, wrftype, &
632	1, 1, 0, memorder, stagger, &
633	dimnames, domain_start, domain_end, domain_start, domain_end, &
634	domain_start, domain_end, istatus)
635	end if
636	#endif
637	real_domain = real(int_domain)
638	deallocate(int_domain)
639	end if
640	#ifdef IO_GRIB1
641	if (io_form_input == GRIB1 .AND. istatus == -5 ) RETURN
642	#endif
643	CALL mprintf((istatus /= 0),ERROR,'In read_field(), got error code %i.', i1=istatus)
644
645
646	END SUBROUTINE arw_read_field
647
648	!------------------------------------------------------------------------------------------
649
650	END MODULE input_module

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

Download in other formats:

Original Format