MODULE input_module USE gridinfo_module USE misc_definitions_module USE module_debug USE module_model_basics USE queue_module #ifdef IO_BINARY USE module_internal_header_util #endif ! WRF I/O API related variables integer :: handle type (queue) :: unit_desc integer :: num_calls, iatts character (len=200), dimension(200) :: catts CONTAINS SUBROUTINE input_init (file_number, istatus) implicit none #include "wrf_io_flags.h" #include "wrf_status_codes.h" ! Arguments integer, intent(in) :: file_number integer, intent(out) :: istatus ! Local variables character (len=128) :: input_fname istatus = 0 CALL arw_ioinit(istatus) istatus = 0 input_fname = ' ' input_fname = trim(input_file_names(file_number)) CALL arw_open_for_read(input_fname, handle, istatus) CALL q_init(unit_desc) num_calls = 0 END SUBROUTINE input_init SUBROUTINE read_next_field (domain_start, domain_end, & cname, cunits, cdesc, memorder, & stagger, dimnames, real_array, valid_date, istatus) implicit none #include "wrf_io_flags.h" #include "wrf_status_codes.h" ! Arguments integer, dimension(3) :: domain_start, domain_end real, pointer, dimension(:,:,:) :: real_array character (len=*), intent(out) :: cname, memorder, stagger, cunits, cdesc character (len=128), dimension(3) :: dimnames integer, intent(inout) :: istatus ! Local variables integer :: ndim, wrftype real, pointer, dimension(:,:,:) :: real_domain character (len=19) :: valid_date type (q_data) :: qd num_calls = num_calls + 1 domain_start = 1 domain_end = 1 #ifdef IO_NETCDF IF (io_form_input == NETCDF) THEN CALL arw_get_next_var(handle, cname, istatus) END IF #endif if (istatus /= 0) return istatus = 0 CALL arw_get_var_info(handle, cname, ndim, memorder, stagger, cdesc, cunits, domain_start, domain_end, wrftype, istatus) if (istatus /= 0) return if (ndim == 0) return if (ndim /= 3) then domain_start(3) = 1 domain_end(3) = 1 end if IF ( ASSOCIATED(real_array) ) DEALLOCATE(real_array) IF ( ASSOCIATED(real_domain) ) DEALLOCATE(real_domain) ALLOCATE(real_domain(domain_end(1), domain_end(2), domain_end(3))) CALL arw_read_field(handle, valid_date, cname, real_domain, wrftype, & memorder, stagger, dimnames, domain_start, domain_end, istatus) if (io_form_input == BINARY) then qd = q_remove(unit_desc) cunits = qd%units cdesc = qd%description else #ifdef IO_NETCDF if (io_form_input == NETCDF) then CALL ext_ncd_get_var_ti_char(handle, 'units', cname, cunits, istatus) CALL ext_ncd_get_var_ti_char(handle, 'description', cname, cdesc, istatus) end if #endif !!#ifdef IO_GRIB1 !! if (io_form_input == GRIB1) then !! CALL ext_gr1_get_var_ti_char(handle, 'units', cname, cunits, istatus) !! CALL ext_gr1_get_var_ti_char(handle, 'description', cname, cdesc, istatus) !! end if !!#endif end if IF (len_trim(cdesc) == 1 ) cdesc = cname !!! Because .ctl must have a description real_array => real_domain END SUBROUTINE read_next_field SUBROUTINE read_spec_field (domain_start, domain_end, cname, wrftype, memorder, & stagger, dimnames, real_array, valid_date, istatus) implicit none #include "wrf_io_flags.h" #include "wrf_status_codes.h" ! Arguments integer, dimension(3) :: domain_start, domain_end real, pointer, dimension(:,:,:) :: real_array character (len=*), intent(in) :: memorder, stagger character (len=*), intent(in) :: cname character (len=128), dimension(3) :: dimnames integer, intent(inout) :: istatus ! Local variables integer :: ndim, wrftype real, pointer, dimension(:,:,:) :: real_domain character (len=19) :: valid_date type (q_data) :: qd istatus = 0 IF ( ASSOCIATED(real_domain) ) DEALLOCATE(real_domain) IF ( ASSOCIATED(real_array) ) DEALLOCATE(real_array) !! IF ( ASSOCIATED(real_domain) ) DEALLOCATE(real_domain) ! nullify(real_domain) ! Bug fix ! IF ( ASSOCIATED(real_array) ) DEALLOCATE(real_array) ALLOCATE(real_domain(domain_end(1), domain_end(2), domain_end(3))) CALL arw_read_field(handle, valid_date, cname, real_domain, wrftype, & memorder, stagger, dimnames, domain_start, domain_end, istatus) real_array => real_domain END SUBROUTINE read_spec_field SUBROUTINE read_global_attrs () implicit none ! Local variables integer :: dyn_opt integer :: outcount, istatus character (len=19) :: start_date character (len=128) :: grid_type character (len=128) :: cunits, cdesc, cstagger, mminlu type (q_data) :: qd real :: dum_r integer :: dum_i iatts = 0 iprogram = 8 CALL arw_get_gbl_att_char(handle, 'TITLE', title, istatus) IF ( INDEX(title,'OUTPUT FROM WRF SI') /= 0 ) iprogram = 0 !! WRFSI output IF (trim(title) == 'OUTPUT FROM GRIDGEN') iprogram = 1 !! geogrid output IF (trim(title) == 'OUTPUT FROM METGRID') iprogram = 3 !! metgrid output IF ( INDEX(title,'OUTPUT FROM REAL_EM') /= 0 ) iprogram = 6 !! real.exe output CALL arw_get_gbl_att_char(handle, 'SIMULATION_START_DATE', start_date, istatus) CALL arw_get_gbl_att_char(handle, 'GRIDTYPE', grid_type, istatus) CALL arw_get_gbl_att_char(handle, 'MMINLU', mminlu, istatus) !! Make sure we are working with the unstaggered values here CALL arw_get_gbl_att_int_sca(handle, 'WEST-EAST_GRID_DIMENSION', west_east_dim, 1, outcount, istatus) west_east_dim = west_east_dim - 1 CALL arw_get_gbl_att_int_sca(handle, 'SOUTH-NORTH_GRID_DIMENSION', south_north_dim, 1, outcount, istatus) south_north_dim = south_north_dim - 1 CALL arw_get_gbl_att_int_sca(handle, 'BOTTOM-TOP_GRID_DIMENSION', bottom_top_dim, 1, outcount, istatus) !!!! !!!! fix to allow the use of ncrcat to reduce vertical levels number in wrfout input files !!!! include "../change_bottom_top_dim" !!!! !!!! IF ( iprogram .le. 1 ) bottom_top_dim = 24 !!! Just to make room for the 3D datasets IF ( iprogram .ge. 6 ) bottom_top_dim = bottom_top_dim - 1 CALL arw_get_gbl_att_int_sca(handle, 'DYN_OPT', dyn_opt, 1, outcount, istatus) CALL arw_get_gbl_att_int_sca(handle, 'MAP_PROJ', map_proj, 1, outcount, istatus) CALL arw_get_gbl_att_real_sca(handle, 'DX', dx, 1, outcount, istatus) CALL arw_get_gbl_att_real_sca(handle, 'DY', dy, 1, outcount, istatus) CALL arw_get_gbl_att_real_sca(handle, 'CEN_LAT', cen_lat, 1, outcount, istatus) CALL arw_get_gbl_att_real_sca(handle, 'CEN_LON', cen_lon, 1, outcount, istatus) CALL arw_get_gbl_att_real_sca(handle, 'TRUELAT1', truelat1, 1, outcount, istatus) CALL arw_get_gbl_att_real_sca(handle, 'TRUELAT2', truelat2, 1, outcount, istatus) CALL arw_get_gbl_att_real_sca(handle, 'MOAD_CEN_LAT', moad_cen_lat, 1, outcount, istatus) CALL arw_get_gbl_att_real_sca(handle, 'STAND_LON', stand_lon, 1, outcount, istatus) !!CALL arw_get_gbl_att_real_arr(handle, 'corner_lats', corner_lats, 16, outcount, istatus) !!CALL arw_get_gbl_att_real_arr(handle, 'corner_lons', corner_lons, 16, outcount, istatus) !!! Just needed for meta data in the .ctl file !CALL arw_get_gbl_att_int_sca(handle, 'DYN_OPT', dum_i, 1, outcount, istatus) !CALL arw_get_gbl_att_int_sca(handle, 'DIFF_OPT', dum_i, 1, outcount, istatus) !CALL arw_get_gbl_att_int_sca(handle, 'KM_OPT', dum_i, 1, outcount, istatus) !CALL arw_get_gbl_att_int_sca(handle, 'DAMP_OPT', dum_i, 1, outcount, istatus) !CALL arw_get_gbl_att_real_sca(handle, 'KHDIF', dum_r, 1, outcount, istatus) !CALL arw_get_gbl_att_real_sca(handle, 'KVDIF', dum_r, 1, outcount, istatus) !CALL arw_get_gbl_att_int_sca(handle, 'MP_PHYSICS', dum_i, 1, outcount, istatus) !CALL arw_get_gbl_att_int_sca(handle, 'RA_LW_PHYSICS', dum_i, 1, outcount, istatus) !CALL arw_get_gbl_att_int_sca(handle, 'RA_SW_PHYSICS', dum_i, 1, outcount, istatus) !CALL arw_get_gbl_att_int_sca(handle, 'SF_SFCLAY_PHYSICS', dum_i, 1, outcount, istatus) !CALL arw_get_gbl_att_int_sca(handle, 'SF_SURFACE_PHYSICS', dum_i, 1, outcount, istatus) !CALL arw_get_gbl_att_int_sca(handle, 'BL_PBL_PHYSICS', dum_i, 1, outcount, istatus) !CALL arw_get_gbl_att_int_sca(handle, 'CU_PHYSICS', dum_i, 1, outcount, istatus) !CALL arw_get_gbl_att_int_sca(handle, 'GRID_ID', dum_i, 1, outcount, istatus) !CALL arw_get_gbl_att_int_sca(handle, 'PARENT_ID', dum_i, 1, outcount, istatus) !CALL arw_get_gbl_att_int_sca(handle, 'I_PARENT_START', dum_i, 1, outcount, istatus) !CALL arw_get_gbl_att_int_sca(handle, 'J_PARENT_START', dum_i, 1, outcount, istatus) !CALL arw_get_gbl_att_int_sca(handle, 'PARENT_GRID_RATIO', dum_i, 1, outcount, istatus) !CALL arw_get_gbl_att_real_sca(handle, 'DT', dum_r, 1, outcount, istatus) !CALL arw_get_gbl_att_int_sca(handle, 'ISWATER', dum_i, 1, outcount, istatus) !CALL arw_get_gbl_att_int_sca(handle, 'ISICE', dum_i, 1, outcount, istatus) !CALL arw_get_gbl_att_int_sca(handle, 'ISURBAN', dum_i, 1, outcount, istatus) !CALL arw_get_gbl_att_int_sca(handle, 'ISOILWATER', dum_i, 1, outcount, istatus) END SUBROUTINE read_global_attrs SUBROUTINE input_close() implicit none ! Local variables integer :: istatus istatus = 0 #ifdef IO_BINARY if (io_form_input == BINARY) then CALL ext_int_ioclose(handle, istatus) CALL ext_int_ioexit(istatus) end if #endif #ifdef IO_NETCDF if (io_form_input == NETCDF) then CALL ext_ncd_ioclose(handle, istatus) CALL ext_ncd_ioexit(istatus) end if #endif #ifdef IO_GRIB1 if (io_form_input == GRIB1) then CALL ext_gr1_ioclose(handle, istatus) CALL ext_gr1_ioexit(istatus) end if #endif CALL q_destroy(unit_desc) END SUBROUTINE input_close !------------------------------------------------------------------------------------------ !------------------------------------------------------------------------------------------ !------------------------------------------------------------------------------------------ SUBROUTINE arw_ioinit (istatus) implicit none ! Arguments integer :: istatus #ifdef IO_BINARY if (io_form_input == BINARY) CALL ext_int_ioinit('sysdep info', istatus) #endif #ifdef IO_NETCDF if (io_form_input == NETCDF) CALL ext_ncd_ioinit('sysdep info', istatus) #endif #ifdef IO_GRIB1 if (io_form_input == GRIB1) CALL ext_gr1_ioinit('sysdep info', istatus) #endif CALL mprintf((istatus /= 0),ERROR,'Error in ext_pkg_ioinit') END SUBROUTINE arw_ioinit !------------------------------------------------------------------------------------------ SUBROUTINE arw_open_for_read (input_fname, handle, istatus) implicit none ! Arguments integer :: handle, istatus character (len=128) :: input_fname #ifdef IO_BINARY if (io_form_input == BINARY) & CALL ext_int_open_for_read(trim(input_fname), 1, 1, 'sysdep info', handle, istatus) #endif #ifdef IO_NETCDF if (io_form_input == NETCDF) & CALL ext_ncd_open_for_read(trim(input_fname), 1, 1, 'sysdep info', handle, istatus) #endif #ifdef IO_GRIB1 if (io_form_input == GRIB1) & CALL ext_gr1_open_for_read(trim(input_fname), 1, 1, 'sysdep info', handle, istatus) #endif CALL mprintf((istatus /= 0),ERROR,'Error in ext_pkg_open_for_read') END SUBROUTINE arw_open_for_read !------------------------------------------------------------------------------------------ SUBROUTINE arw_get_next_time (handle, datestr, istatus) implicit none ! Arguments integer :: handle, istatus character (len=*) :: datestr #ifdef IO_BINARY if (io_form_input == BINARY) CALL ext_int_get_next_time(handle, datestr, istatus) #endif #ifdef IO_NETCDF if (io_form_input == NETCDF) CALL ext_ncd_get_next_time(handle, datestr, istatus) #endif #ifdef IO_GRIB1 if (io_form_input == GRIB1) CALL ext_gr1_get_next_time(handle, datestr, istatus) #endif !!CALL mprintf((istatus /= 0),ERROR,'Error while reading next time .') END SUBROUTINE arw_get_next_time !------------------------------------------------------------------------------------------ SUBROUTINE arw_get_gbl_att_char (handle, att_string, att, istatus) implicit none ! Arguments integer :: handle, istatus character*(*) :: att_string character (len=*) :: att #ifdef IO_BINARY if (io_form_input == BINARY) CALL ext_int_get_dom_ti_char(handle, att_string, att, istatus) #endif #ifdef IO_NETCDF if (io_form_input == NETCDF) CALL ext_ncd_get_dom_ti_char(handle, att_string, att, istatus) #endif #ifdef IO_GRIB1 if (io_form_input == GRIB1) CALL ext_gr1_get_dom_ti_char(handle, att_string, att, istatus) #endif !!CALL mprintf((istatus /= 0),ERROR,'Error while reading domain global charachter attribute.') IF ( istatus == 0 ) THEN iatts = iatts + 1 WRITE(catts(iatts),'("@ global String comment ",A," = ",A)') trim(att_string), trim(att) END IF END SUBROUTINE arw_get_gbl_att_char !------------------------------------------------------------------------------------------ SUBROUTINE arw_get_gbl_att_int_sca (handle, att_string, att, dim, outcount, istatus) implicit none ! Arguments integer :: handle, dim, outcount, istatus character*(*) :: att_string integer :: att #ifdef IO_BINARY if (io_form_input == BINARY) CALL ext_int_get_dom_ti_integer(handle, att_string, att, dim, outcount, istatus) #endif #ifdef IO_NETCDF if (io_form_input == NETCDF) CALL ext_ncd_get_dom_ti_integer(handle, att_string, att, dim, outcount, istatus) #endif #ifdef IO_GRIB1 if (io_form_input == GRIB1) CALL ext_gr1_get_dom_ti_integer(handle, att_string, att, dim, outcount, istatus) #endif !!CALL mprintf((istatus /= 0),ERROR,'Error while reading domain global integer attribute.') IF ( istatus == 0 ) THEN iatts = iatts + 1 WRITE(catts(iatts),'("@ global String comment ",A," = ",i5)') trim(att_string), att END IF END SUBROUTINE arw_get_gbl_att_int_sca !------------------------------------------------------------------------------------------ SUBROUTINE arw_get_gbl_att_real_sca (handle, att_string, att, dim, outcount, istatus) implicit none ! Arguments integer :: handle, dim, outcount, istatus character*(*) :: att_string real :: att #ifdef IO_BINARY if (io_form_input == BINARY) CALL ext_int_get_dom_ti_real(handle, att_string, att, dim, outcount, istatus) #endif #ifdef IO_NETCDF if (io_form_input == NETCDF) CALL ext_ncd_get_dom_ti_real(handle, att_string, att, dim, outcount, istatus) #endif #ifdef IO_GRIB1 if (io_form_input == GRIB1) CALL ext_gr1_get_dom_ti_real(handle, att_string, att, dim, outcount, istatus) #endif !!CALL mprintf((istatus /= 0),ERROR,'Error while reading domain global real attribute.') IF ( istatus == 0 ) THEN iatts = iatts + 1 WRITE(catts(iatts),'("@ global String comment ",A," = ",f12.2)') trim(att_string), att END IF END SUBROUTINE arw_get_gbl_att_real_sca !------------------------------------------------------------------------------------------ SUBROUTINE arw_get_gbl_att_real_arr (handle, att_string, att, dim, outcount, istatus) implicit none ! Arguments integer :: handle, dim, outcount, istatus character*(*) :: att_string real, dimension(*) :: att #ifdef IO_BINARY if (io_form_input == BINARY) CALL ext_int_get_dom_ti_real(handle, att_string, att, dim, outcount, istatus) #endif #ifdef IO_NETCDF if (io_form_input == NETCDF) CALL ext_ncd_get_dom_ti_real(handle, att_string, att, dim, outcount, istatus) #endif #ifdef IO_GRIB1 if (io_form_input == GRIB1) CALL ext_gr1_get_dom_ti_real(handle, att_string, att, dim, outcount, istatus) #endif CALL mprintf((istatus /= 0),ERROR,'Error while reading domain global real attribute.') END SUBROUTINE arw_get_gbl_att_real_arr !------------------------------------------------------------------------------------------ SUBROUTINE arw_get_next_var (handle, cname, istatus) implicit none ! Arguments integer :: handle, istatus character*(*) :: cname #ifdef IO_BINARY if (io_form_input == BINARY) CALL ext_int_get_next_var(handle, cname, istatus) #endif #ifdef IO_NETCDF if (io_form_input == NETCDF) CALL ext_ncd_get_next_var(handle, cname, istatus) #endif #ifdef IO_GRIB1 if (io_form_input == GRIB1) CALL ext_gr1_get_next_var(handle, cname, istatus) #endif END SUBROUTINE arw_get_next_var !------------------------------------------------------------------------------------------ SUBROUTINE arw_get_var_info (handle, cname, ndim, memorder, stagger, cdesc, cunits, domain_start, domain_end, wrftype, istatus) implicit none ! Arguments integer :: handle, istatus integer :: ndim, wrftype integer, dimension(3) :: domain_start, domain_end character*(*) :: cname, memorder, stagger, cdesc, cunits cunits = ' ' cdesc = ' ' #ifdef IO_BINARY if (io_form_input == BINARY) & CALL ext_int_get_var_info(handle, cname, ndim, memorder, stagger, domain_start, domain_end, wrftype, istatus) #endif #ifdef IO_NETCDF if (io_form_input == NETCDF) & CALL ext_ncd_get_var_info(handle, cname, ndim, memorder, stagger, domain_start, domain_end, wrftype, istatus) #endif #ifdef IO_GRIB1 IF (io_form_input == GRIB1) THEN 10 read (13,'(i3,5x,A3,4x,A1,5x,A13,A48,A15)',END=999) wrftype, memorder, stagger, cname, cdesc, cunits ndim = LEN_trim(memorder) IF (iprogram .le. 1 .AND. ndim == 3 .AND. INDEX(memorder,'m') == 0) GOTO 10 IF (iprogram .le. 1 .AND. ndim == 1) GOTO 10 IF (iprogram == 8 .AND. INDEX(memorder,'g') /= 0) GOTO 10 IF ( LEN_trim(memorder) == 3 ) THEN domain_end(1) = west_east_dim domain_end(2) = south_north_dim domain_end(3) = bottom_top_dim IF (stagger(1:1) == "X") domain_end(1) = domain_end(1) + 1 IF (stagger(1:1) == "Y") domain_end(2) = domain_end(2) + 1 IF (iprogram .ge. 6 .AND. stagger(1:1) == "Z") domain_end(3) = domain_end(3) + 1 IF ( INDEX(memorder,'m') /= 0 ) domain_end(3) = 12 IF ( INDEX(memorder,'u') /= 0 ) domain_end(3) = 24 memorder = "XYZ" ELSE IF ( LEN_trim(memorder) == 2 ) THEN domain_end(1) = west_east_dim domain_end(2) = south_north_dim IF (stagger(1:1) == "X") domain_end(1) = domain_end(1) + 1 IF (stagger(1:1) == "Y") domain_end(2) = domain_end(2) + 1 memorder = "XY" ELSE IF ( LEN_trim(memorder) == 1 ) THEN domain_end(1) = bottom_top_dim IF (iprogram .ge. 6 .AND. stagger(1:1) == "Z") domain_end(1) = domain_end(1) + 1 memorder = "Z" END IF END IF #endif CALL mprintf((istatus /= 0),ERROR,'In read_next_field(), problems with ext_pkg_get_var_info()') RETURN 999 istatus = -1 !!! Reached end of file END SUBROUTINE arw_get_var_info !------------------------------------------------------------------------------------------ SUBROUTINE arw_read_field (handle, valid_date, cname, real_domain, wrftype, & memorder, stagger, & dimnames, domain_start, domain_end, istatus) implicit none ! Arguments integer :: handle, istatus integer :: ndim, wrftype integer, dimension(3) :: domain_start, domain_end character*(*) :: cname, memorder, stagger, valid_date character (len=128), dimension(3) :: dimnames real, pointer, dimension(:,:,:) :: real_domain integer, pointer, dimension(:,:,:) :: int_domain #include "wrf_io_flags.h" #include "wrf_status_codes.h" !!! caca !print *, 'arw_read_field ', handle, valid_date, cname, wrftype, & ! memorder, stagger, & ! dimnames, domain_start, domain_end, istatus !!! caca if (wrftype == WRF_REAL) then #ifdef IO_BINARY if (io_form_input == BINARY) then CALL ext_int_read_field(handle, valid_date, cname, real_domain, wrftype, & 1, 1, 0, memorder, stagger, & dimnames, domain_start, domain_end, domain_start, domain_end, & domain_start, domain_end, istatus) end if #endif #ifdef IO_NETCDF if (io_form_input == NETCDF) then CALL ext_ncd_read_field(handle, valid_date, cname, real_domain, wrftype, & 1, 1, 0, memorder, stagger, & dimnames, domain_start, domain_end, domain_start, domain_end, & domain_start, domain_end, istatus) end if #endif #ifdef IO_GRIB1 if (io_form_input == GRIB1) then CALL ext_gr1_read_field(handle, valid_date, cname, real_domain, wrftype, & 1, 1, 0, memorder, stagger, & dimnames, domain_start, domain_end, domain_start, domain_end, & domain_start, domain_end, istatus) end if #endif elseif (wrftype == WRF_INTEGER) then allocate(int_domain(domain_start(1):domain_end(1), domain_start(2):domain_end(2), domain_start(3):domain_end(3))) #ifdef IO_BINARY if (io_form_input == BINARY) then CALL ext_int_read_field(handle, valid_date, cname, int_domain, wrftype, & 1, 1, 0, memorder, stagger, & dimnames, domain_start, domain_end, domain_start, domain_end, & domain_start, domain_end, istatus) end if #endif #ifdef IO_NETCDF if (io_form_input == NETCDF) then CALL ext_ncd_read_field(handle, valid_date, cname, int_domain, wrftype, & 1, 1, 0, memorder, stagger, & dimnames, domain_start, domain_end, domain_start, domain_end, & domain_start, domain_end, istatus) end if #endif #ifdef IO_GRIB1 if (io_form_input == GRIB1) then CALL ext_gr1_read_field(handle, valid_date, cname, int_domain, wrftype, & 1, 1, 0, memorder, stagger, & dimnames, domain_start, domain_end, domain_start, domain_end, & domain_start, domain_end, istatus) end if #endif real_domain = real(int_domain) deallocate(int_domain) end if #ifdef IO_GRIB1 if (io_form_input == GRIB1 .AND. istatus == -5 ) RETURN #endif CALL mprintf((istatus /= 0),ERROR,'In read_field(), got error code %i.', i1=istatus) END SUBROUTINE arw_read_field !------------------------------------------------------------------------------------------ END MODULE input_module