Context Navigation

input_module.F90 @ 897

Last change on this file since 897 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

Rev	Line
[207]	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