module ncdc_metadata use ncd_kinds, only: i_byte, i_short, i_long, r_single, r_double use ncdc_state, only: ncid_input, input_count, input_file, & ncid_output, output_file, & num_unlims, & dim_arr_total, dim_sizes, dim_names, dim_output_ids, & dim_unlim_sizes, & var_arr_total, var_dim_names, var_names, var_types, & var_output_ids, var_hasunlim, & cli_arg_count, & #ifdef USE_MPI data_blobs, & cur_proc #else data_blobs #endif use ncdc_dims, only: nc_diag_cat_lookup_dim, & nc_diag_cat_metadata_add_dim use ncdc_vars, only: nc_diag_cat_metadata_add_var use ncdc_types, only: NC_DIAG_CAT_CHUNK_SIZE, & NC_DIAG_CAT_GZIP_COMPRESS use ncdc_climsg, only: ncdc_error, ncdc_warning, ncdc_info, & ncdc_check use ncdc_cli_process, only: ncdc_usage use netcdf, only: nf90_inquire_attribute, nf90_get_att, & nf90_put_att, nf90_open, nf90_close, nf90_inquire, & nf90_inq_attname, nf90_inquire_dimension, & nf90_inquire_variable, nf90_def_dim, nf90_def_var, & nf90_def_var_chunking, nf90_def_var_deflate, & NF90_BYTE, NF90_SHORT, NF90_INT, NF90_FLOAT, NF90_DOUBLE, & NF90_CHAR, NF90_FILL_BYTE, NF90_FILL_SHORT, NF90_FILL_INT, & NF90_FILL_FLOAT, NF90_FILL_DOUBLE, NF90_FILL_CHAR, & NF90_GLOBAL, NF90_NOWRITE, NF90_ENOTATT, & NF90_NOERR, NF90_MAX_NAME, NF90_UNLIMITED, NF90_CHUNKED use netcdf_unlimdims, only: pf_nf90_inq_unlimdims implicit none contains subroutine nc_diag_cat_copy_attr(attr_name, var_id_in, var_id_out) character(len=*), intent(in) :: attr_name integer(i_long), intent(in) :: var_id_in integer(i_long), intent(in), optional :: var_id_out integer(i_byte), dimension(:), allocatable :: byte_arr integer(i_short),dimension(:), allocatable :: short_arr integer(i_long), dimension(:), allocatable :: long_arr real(r_single),dimension(:), allocatable :: rsingle_arr real(r_double),dimension(:), allocatable :: rdouble_arr character(len=:), allocatable :: string_arr integer(i_long) :: attr_type, attr_len, final_var_id_out call ncdc_check(nf90_inquire_attribute(ncid_input, var_id_in, attr_name, & xtype = attr_type, len = attr_len)) if (.NOT. present(var_id_out)) then if (var_id_in /= NF90_GLOBAL) & call ncdc_error("BUG! var_id_out not specified even when var_id_in is var-specific!") final_var_id_out = var_id_in else final_var_id_out = var_id_out end if if (attr_type == NF90_BYTE) then allocate(byte_arr(attr_len)) call ncdc_check(nf90_get_att(ncid_input, var_id_in, attr_name, byte_arr)) call ncdc_check(nf90_put_att(ncid_output, final_var_id_out, attr_name, byte_arr)) deallocate(byte_arr) else if (attr_type == NF90_SHORT) then allocate(short_arr(attr_len)) call ncdc_check(nf90_get_att(ncid_input, var_id_in, attr_name, short_arr)) call ncdc_check(nf90_put_att(ncid_output, final_var_id_out, attr_name, short_arr)) deallocate(short_arr) else if (attr_type == NF90_INT) then allocate(long_arr(attr_len)) call ncdc_check(nf90_get_att(ncid_input, var_id_in, attr_name, long_arr)) call ncdc_check(nf90_put_att(ncid_output, final_var_id_out, attr_name, long_arr)) deallocate(long_arr) else if (attr_type == NF90_FLOAT) then allocate(rsingle_arr(attr_len)) call ncdc_check(nf90_get_att(ncid_input, var_id_in, attr_name, rsingle_arr)) call ncdc_check(nf90_put_att(ncid_output, final_var_id_out, attr_name, rsingle_arr)) deallocate(rsingle_arr) else if (attr_type == NF90_DOUBLE) then allocate(rdouble_arr(attr_len)) call ncdc_check(nf90_get_att(ncid_input, var_id_in, attr_name, rdouble_arr)) call ncdc_check(nf90_put_att(ncid_output, final_var_id_out, attr_name, rdouble_arr)) deallocate(rdouble_arr) else if (attr_type == NF90_CHAR) then allocate(character(len=attr_len) :: string_arr) call ncdc_check(nf90_get_att(ncid_input, var_id_in, attr_name, string_arr)) call ncdc_check(nf90_put_att(ncid_output, final_var_id_out, attr_name, string_arr)) deallocate(string_arr) else call ncdc_error("Unable to copy attribute for unknown type!") end if end subroutine nc_diag_cat_copy_attr subroutine nc_diag_cat_metadata_pass character(len=1000) :: err_string integer(i_long) :: old_dim_arr_total = 0, old_var_arr_total = 0 integer(i_long) :: tmp_dim_index, tmp_attr_index integer(i_long) :: input_ndims, cached_ndims = -1 integer(i_long) :: input_nvars, cached_nvars = -1 integer(i_long) :: input_nattrs character(len=NF90_MAX_NAME) :: tmp_var_name integer(i_long) :: tmp_var_type, tmp_var_ndims integer(i_long), dimension(:), allocatable :: tmp_var_dimids character(len=NF90_MAX_NAME) , allocatable :: tmp_var_dim_names(:) integer(i_long), dimension(:), allocatable :: unlim_dims logical :: is_unlim = .FALSE. character(len=NF90_MAX_NAME) :: tmp_dim_name, tmp_attr_name integer(i_long) :: tmp_dim_size integer(i_long) :: arg_index, var_index, i integer(i_long) :: nc_err character(:), allocatable :: input_file_cut input_count = cli_arg_count - 2 #ifndef QUIET #ifdef USE_MPI if (cur_proc == 0) & #endif call ncdc_info("Scanning NetCDF files for dimensions and variables...") #endif do arg_index = 1, input_count call get_command_argument(2 + arg_index, input_file) input_file_cut = trim(input_file) if (len(input_file_cut) <= 0) then call ncdc_usage("Invalid input file name - likely blank!") end if if (input_file_cut == output_file) then call ncdc_warning(" -> Ignoring output file in input file list.") call ncdc_info(" -> Skipping " // input_file_cut // " since it is the output file...") else #ifndef QUIET #ifdef USE_MPI if (cur_proc == 0) & #endif call ncdc_info(" -> Opening " // input_file_cut // " for reading...") #endif call ncdc_check(nf90_open(input_file, NF90_NOWRITE, ncid_input)) ! Get top level info about the file! call ncdc_check(nf90_inquire(ncid_input, nDimensions = input_ndims, & nVariables = input_nvars, nAttributes = input_nattrs)) #ifdef USE_MPI if (cur_proc == 0) then #endif ! Fetch attributes and only add if they are NOT in the final file do tmp_attr_index = 1, input_nattrs call ncdc_check(nf90_inq_attname(ncid_input, NF90_GLOBAL, tmp_attr_index, tmp_attr_name)) nc_err = nf90_inquire_attribute(ncid_output, & NF90_GLOBAL, trim(tmp_attr_name)) ! If attribute doesn't exist, add it! if (nc_err == NF90_ENOTATT) then call nc_diag_cat_copy_attr(trim(tmp_attr_name), NF90_GLOBAL) else if (nc_err /= NF90_NOERR) then ! Sanity check - could be another error! call ncdc_check(nc_err) end if end do #ifdef USE_MPI end if #endif #ifdef DEBUG write (*, "(A, I0)") "Number of dimensions: ", input_ndims #endif if (cached_ndims == -1) & cached_ndims = input_ndims if (input_ndims == 0) then #ifndef QUIET call ncdc_warning("No dimensions found in file " // input_file_cut // "! Skipping file...") #endif call ncdc_check(nf90_close(ncid_input)) cycle end if #ifndef QUIET if (input_nvars == 0) & call ncdc_warning("No variables found in file " // input_file_cut // "!") if (cached_ndims /= input_ndims) & call ncdc_warning("Number of dimensions in " // trim(input_file) // " does not match first input file.") #endif ! Get unlimited dimension information call ncdc_check(pf_nf90_inq_unlimdims(ncid_input, num_unlims)) #ifdef DEBUG write (*, "(A, I0)") "Number of unlimited dimensions: ", num_unlims #endif allocate(unlim_dims(num_unlims)) call ncdc_check(pf_nf90_inq_unlimdims(ncid_input, num_unlims, unlim_dims)) ! Loop through each dimension! do tmp_dim_index = 1, input_ndims call ncdc_check(nf90_inquire_dimension(ncid_input, tmp_dim_index, & tmp_dim_name, tmp_dim_size)) is_unlim = .FALSE. do i = 1, num_unlims if (tmp_dim_index == unlim_dims(i)) then is_unlim = .TRUE. exit end if end do if (is_unlim) then #ifdef DEBUG write (*, "(A, I0, A, I0, A)") " => Dimension #", tmp_dim_index, ": " // & trim(tmp_dim_name) // " (size: ", & tmp_dim_size, & " - UNLIMITED)" #endif call nc_diag_cat_metadata_add_dim(tmp_dim_name, -1, tmp_dim_size) else #ifdef DEBUG write (*, "(A, I0, A, I0, A)") " => Dimension #", tmp_dim_index, ": " // & trim(tmp_dim_name) // " (size: ", & tmp_dim_size, & ")" #endif call nc_diag_cat_metadata_add_dim(trim(tmp_dim_name), tmp_dim_size) end if end do deallocate(unlim_dims) ! Variables #ifdef DEBUG write (*, "(A, I0)") "Number of variables: ", input_nvars #endif if (cached_nvars == -1) cached_nvars = input_nvars #ifndef QUIET if (cached_nvars /= input_nvars) & call ncdc_warning("Number of variables in " // trim(input_file) // " does not match first input file.") #endif if (input_nvars == 0) then call ncdc_check(nf90_close(ncid_input)) cycle end if ! Loop through each variable! do var_index = 1, input_nvars ! Grab number of dimensions and attributes first call ncdc_check(nf90_inquire_variable(ncid_input, var_index, name = tmp_var_name, & ndims = tmp_var_ndims, xtype = tmp_var_type)) ! Allocate temporary variable dimids storage! allocate(tmp_var_dimids(tmp_var_ndims)) allocate(tmp_var_dim_names(tmp_var_ndims)) ! Grab the actual dimension IDs and attributes call ncdc_check(nf90_inquire_variable(ncid_input, var_index, dimids = tmp_var_dimids, & xtype = tmp_var_type)) if ((tmp_var_ndims <= 2) .OR. & ((tmp_var_ndims == 3) .AND. (tmp_var_type == NF90_CHAR))) then #ifdef DEBUG write (*, "(A, I0, A, I0)") " => Variable #", var_index, ": " // & trim(tmp_var_name) write (*, "(A)", advance = "NO") " => Dimension IDs: " do i = 1, tmp_var_ndims if (i /= 1) write (*, "(A)", advance = "NO") ", " write (*, "(I0)", advance = "NO") tmp_var_dimids(i) end do write (*, "(A)") "" write (*, "(A)", advance = "NO") " => Dimensions: " #endif do i = 1, tmp_var_ndims #ifdef DEBUG if (i /= 1) write (*, "(A)", advance = "NO") ", " #endif call ncdc_check(nf90_inquire_dimension(ncid_input, tmp_var_dimids(i), tmp_var_dim_names(i))) #ifdef DEBUG write (*, "(A)", advance = "NO") trim(tmp_var_dim_names(i)) #endif end do #ifdef DEBUG write (*, "(A)") "" #endif call nc_diag_cat_metadata_add_var(trim(tmp_var_name), tmp_var_type, tmp_var_ndims, tmp_var_dim_names) else write (err_string, "(A, I0, A)") & "Variables with >2 dimensions NOT supported." // & CHAR(10) // " " // & "(Variable '" // trim(tmp_var_name) // "' has ", & tmp_var_ndims, & " dimensions!)" call ncdc_error(trim(err_string)) end if ! Deallocate deallocate(tmp_var_dimids) deallocate(tmp_var_dim_names) end do #ifdef DEBUG write (*, "(A)") " => For all variables, the order of dimensions are INVERTED!" #endif call ncdc_check(nf90_close(ncid_input)) old_dim_arr_total = dim_arr_total old_var_arr_total = var_arr_total end if end do end subroutine nc_diag_cat_metadata_pass subroutine nc_diag_cat_metadata_define integer(i_long) :: i, j call ncdc_info("Creating new dimensions and variables for output file...") call ncdc_info(" -> Defining dimensions...") if (dim_arr_total == 0) & call ncdc_warning("No dimensions found in input files, so not defining anything.") do i = 1, dim_arr_total if (dim_sizes(i) == -1) then call ncdc_check(nf90_def_dim(ncid_output, dim_names(i), & NF90_UNLIMITED, dim_output_ids(i))) else call ncdc_check(nf90_def_dim(ncid_output, dim_names(i), & dim_sizes(i), dim_output_ids(i))) end if #ifdef DEBUG write(*, "(A, I0, A, I0)") "STORED DIMID for dim " // trim(dim_names(i)) // ": ", & dim_output_ids(i), " | size: ", dim_sizes(i) #endif end do if (var_arr_total == 0) & call ncdc_warning("No variables found in input files, so not defining anything.") call ncdc_info(" -> Defining variables...") do i = 1, var_arr_total do j = 1, var_dim_names(i)%num_names var_dim_names(i)%output_dim_ids(j) = & dim_output_ids(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(j))) #ifdef DEBUG write(*, "(A, I0)") "Paired ID for dim " // trim(var_dim_names(i)%dim_names(j)) // ": ", & var_dim_names(i)%output_dim_ids(j) #endif end do #ifdef DEBUG write (*, "(A, I0, A)") "Defining variable: " // trim(var_names(i)) // " (type = ", var_types(i), ")" print *, "var_dim_names(i)%output_dim_ids", var_dim_names(i)%output_dim_ids print *, "LEN var_dim_names(i)%output_dim_ids", size(var_dim_names(i)%output_dim_ids) #endif call ncdc_check(nf90_def_var(ncid_output, var_names(i), var_types(i), & var_dim_names(i)%output_dim_ids, & var_output_ids(i))) #ifdef DEBUG if (var_dim_names(i)%num_names == 1) print *, "DIM #1", var_dim_names(i)%dim_names(1) if (var_dim_names(i)%num_names == 2) print *, "DIM #2", var_dim_names(i)%dim_names(2) if (var_dim_names(i)%num_names == 3) print *, "DIM #3", var_dim_names(i)%dim_names(3) #endif if (var_hasunlim(i)) then if (var_dim_names(i)%num_names == 1) then call ncdc_check(nf90_def_var_chunking(ncid_output, var_output_ids(i), & NF90_CHUNKED, (/ NC_DIAG_CAT_CHUNK_SIZE /) )) else if (var_dim_names(i)%num_names == 2) then call ncdc_check(nf90_def_var_chunking(ncid_output, var_output_ids(i), & NF90_CHUNKED, (/ dim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(1))), & NC_DIAG_CAT_CHUNK_SIZE /) )) else if (var_dim_names(i)%num_names == 3) then call ncdc_check(nf90_def_var_chunking(ncid_output, var_output_ids(i), & NF90_CHUNKED, & (/ dim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(1))), & dim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(2))), & NC_DIAG_CAT_CHUNK_SIZE /) )) end if else if (var_dim_names(i)%num_names == 1) then call ncdc_check(nf90_def_var_chunking(ncid_output, var_output_ids(i), & NF90_CHUNKED, (/ dim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(1))) /) )) else if (var_dim_names(i)%num_names == 2) then call ncdc_check(nf90_def_var_chunking(ncid_output, var_output_ids(i), & NF90_CHUNKED, (/ dim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(1))), & dim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(2))) /) )) else if (var_dim_names(i)%num_names == 3) then call ncdc_check(nf90_def_var_chunking(ncid_output, var_output_ids(i), & NF90_CHUNKED, & (/ dim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(1))), & dim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(2))), & dim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(3))) /) )) end if end if call ncdc_check(nf90_def_var_deflate(ncid_output, var_output_ids(i), & shuffle = 1, deflate = 1, deflate_level = NC_DIAG_CAT_GZIP_COMPRESS)) end do end subroutine nc_diag_cat_metadata_define subroutine nc_diag_cat_metadata_alloc integer(i_long), dimension(3) :: alloc_dim_sizes = 0 integer(i_long) :: i ! Next portion depends on defines/vars in ncdc_data_decl.F90 call ncdc_info(" -> Allocating data storage for variables...") allocate(data_blobs(var_arr_total)) do i = 1, var_arr_total if (var_dim_names(i)%num_names == 1) then alloc_dim_sizes = (/ & dim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(1))), & 0, & 0 /) ! Check for unlimited sizes and replace them! if (alloc_dim_sizes(1) == -1) & alloc_dim_sizes(1) = & dim_unlim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(1))) if (var_types(i) == NF90_BYTE) allocate(data_blobs(i)%byte_buffer(alloc_dim_sizes(1))) if (var_types(i) == NF90_SHORT) allocate(data_blobs(i)%short_buffer(alloc_dim_sizes(1))) if (var_types(i) == NF90_INT) allocate(data_blobs(i)%long_buffer(alloc_dim_sizes(1))) if (var_types(i) == NF90_FLOAT) allocate(data_blobs(i)%rsingle_buffer(alloc_dim_sizes(1))) if (var_types(i) == NF90_DOUBLE) allocate(data_blobs(i)%rdouble_buffer(alloc_dim_sizes(1))) if (var_types(i) == NF90_CHAR) call ncdc_error("1D character variable type not supported!") if (var_types(i) == NF90_BYTE) data_blobs(i)%byte_buffer = NF90_FILL_BYTE if (var_types(i) == NF90_SHORT) data_blobs(i)%short_buffer = NF90_FILL_SHORT if (var_types(i) == NF90_INT) data_blobs(i)%long_buffer = NF90_FILL_INT if (var_types(i) == NF90_FLOAT) data_blobs(i)%rsingle_buffer = NF90_FILL_FLOAT if (var_types(i) == NF90_DOUBLE) data_blobs(i)%rdouble_buffer = NF90_FILL_DOUBLE else if (var_dim_names(i)%num_names == 2) then alloc_dim_sizes = (/ & dim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(1))), & dim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(2))), & 0 /) ! Check for unlimited sizes and replace them! if (alloc_dim_sizes(2) == -1) & alloc_dim_sizes(2) = & dim_unlim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(2))) if (var_types(i) == NF90_BYTE) allocate(data_blobs(i)%byte_2d_buffer(alloc_dim_sizes(1), alloc_dim_sizes(2))) if (var_types(i) == NF90_SHORT) allocate(data_blobs(i)%short_2d_buffer(alloc_dim_sizes(1), alloc_dim_sizes(2))) if (var_types(i) == NF90_INT) allocate(data_blobs(i)%long_2d_buffer(alloc_dim_sizes(1), alloc_dim_sizes(2))) if (var_types(i) == NF90_FLOAT) allocate(data_blobs(i)%rsingle_2d_buffer(alloc_dim_sizes(1), alloc_dim_sizes(2))) if (var_types(i) == NF90_DOUBLE) allocate(data_blobs(i)%rdouble_2d_buffer(alloc_dim_sizes(1), alloc_dim_sizes(2))) if (var_types(i) == NF90_CHAR) allocate(data_blobs(i)%string_buffer(alloc_dim_sizes(1), alloc_dim_sizes(2))) if (var_types(i) == NF90_BYTE) data_blobs(i)%byte_2d_buffer = NF90_FILL_BYTE if (var_types(i) == NF90_SHORT) data_blobs(i)%short_2d_buffer = NF90_FILL_SHORT if (var_types(i) == NF90_INT) data_blobs(i)%long_2d_buffer = NF90_FILL_INT if (var_types(i) == NF90_FLOAT) data_blobs(i)%rsingle_2d_buffer = NF90_FILL_FLOAT if (var_types(i) == NF90_DOUBLE) data_blobs(i)%rdouble_2d_buffer = NF90_FILL_DOUBLE if (var_types(i) == NF90_CHAR) data_blobs(i)%string_buffer = NF90_FILL_CHAR else if (var_dim_names(i)%num_names == 3) then alloc_dim_sizes = (/ & dim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(1))), & dim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(2))), & dim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(3))) /) ! Check for unlimited sizes and replace them! ! (Though, this should always be the case...) if (alloc_dim_sizes(3) == -1) & alloc_dim_sizes(3) = & dim_unlim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(3))) if (var_types(i) == NF90_CHAR) then allocate(data_blobs(i)%string_2d_buffer(alloc_dim_sizes(1), alloc_dim_sizes(2), alloc_dim_sizes(3))) data_blobs(i)%string_2d_buffer = NF90_FILL_CHAR else call ncdc_error("3D non-character variable type not supported!") end if end if data_blobs(i)%alloc_size = alloc_dim_sizes !print *, trim(var_names(i)), data_blobs(i)%alloc_size end do #ifdef DEBUG print *, "!! END DEFINITION PASS" #endif end subroutine nc_diag_cat_metadata_alloc end module ncdc_metadata