Builds a new index from several work matrices.
Type | Intent | Optional | Attributes | Name | ||
---|---|---|---|---|---|---|
integer, | intent(in), | DIMENSION(*) | :: | new_row_p | ||
integer, | intent(out), | DIMENSION(*), TARGET | :: | new_col_i | ||
integer, | intent(out), | DIMENSION(*), TARGET | :: | new_blk_p | ||
integer, | intent(in), | DIMENSION(*), TARGET | :: | blk_d | ||
integer, | intent(in), | DIMENSION(*) | :: | old_row_p | ||
integer, | intent(in), | DIMENSION(*) | :: | old_col_i | ||
integer, | intent(in), | DIMENSION(*) | :: | old_blk_p | ||
type(i_array_p), | intent(in), | DIMENSION(*) | :: | all_row_p | ||
type(i_array_p), | intent(in), | DIMENSION(*) | :: | all_col_i | ||
type(i_array_p), | intent(in), | DIMENSION(*) | :: | all_blk_p | ||
integer, | intent(in), | DIMENSION(*) | :: | all_data_offsets | ||
integer, | intent(in) | :: | nwms | |||
integer, | intent(in) | :: | nrows | |||
integer, | intent(in) | :: | max_row_count | |||
logical, | intent(in) | :: | sort_data |
SUBROUTINE merge_index(new_row_p, new_col_i, new_blk_p, & !! Builds a new index from several work matrices. blk_d, old_row_p, old_col_i, old_blk_p, & all_row_p, all_col_i, all_blk_p, & all_data_offsets, nwms, nrows, max_row_count, sort_data) INTEGER, DIMENSION(*), INTENT(IN) :: new_row_p INTEGER, DIMENSION(*), INTENT(OUT), TARGET :: new_col_i, new_blk_p INTEGER, DIMENSION(*), INTENT(IN), TARGET :: blk_d INTEGER, DIMENSION(*), INTENT(IN) :: old_row_p, old_col_i, old_blk_p TYPE(i_array_p), DIMENSION(*), INTENT(IN) :: all_row_p, all_col_i, all_blk_p INTEGER, DIMENSION(*), INTENT(IN) :: all_data_offsets INTEGER, INTENT(IN) :: nwms, nrows, max_row_count LOGICAL, INTENT(IN) :: sort_data CHARACTER(len=*), PARAMETER :: routineN = 'merge_index' INTEGER :: blk1, blk2, error_handle, first_row_blk, & last_row_blk, row, src_blk_1, & src_blk_2, t INTEGER, ALLOCATABLE, DIMENSION(:) :: blk_p_buff, tmp_arr INTEGER, DIMENSION(:), POINTER, CONTIGUOUS :: blk_span, col_span, d_span ! --------------------------------------------------------------------------- CALL timeset(routineN, error_handle) ! ALLOCATE (tmp_arr(max_row_count)) ALLOCATE (blk_p_buff(max_row_count)) ! !$OMP DO DO row = 1, nrows first_row_blk = new_row_p(row) + 1 last_row_blk = new_row_p(row + 1) col_span => new_col_i(first_row_blk:last_row_blk) blk_span => new_blk_p(first_row_blk:last_row_blk) IF (sort_data) d_span => blk_d(first_row_blk:last_row_blk) src_blk_1 = old_row_p(row) + 1 src_blk_2 = old_row_p(row + 1) blk1 = 1 blk2 = blk1 + (src_blk_2 - src_blk_1 + 1) - 1 col_span(blk1:blk2) = old_col_i(src_blk_1:src_blk_2) blk_span(blk1:blk2) = old_blk_p(src_blk_1:src_blk_2) IF (sort_data) THEN d_span(blk1:blk2) = 1 DO t = 1, nwms src_blk_1 = all_row_p(t)%p(row) + 1 src_blk_2 = all_row_p(t)%p(row + 1) blk1 = blk2 + 1 blk2 = blk1 + (src_blk_2 - src_blk_1 + 1) - 1 col_span(blk1:blk2) = all_col_i(t)%p(src_blk_1:src_blk_2) blk_span(blk1:blk2) = all_blk_p(t)%p(src_blk_1:src_blk_2) d_span(blk1:blk2) = t + 1 END DO ELSE DO t = 1, nwms src_blk_1 = all_row_p(t)%p(row) + 1 src_blk_2 = all_row_p(t)%p(row + 1) blk1 = blk2 + 1 blk2 = blk1 + (src_blk_2 - src_blk_1 + 1) - 1 col_span(blk1:blk2) = all_col_i(t)%p(src_blk_1:src_blk_2) blk_span(blk1:blk2) = all_blk_p(t)%p(src_blk_1:src_blk_2) & & + all_data_offsets(t) END DO END IF CALL sort(col_span, SIZE(col_span), tmp_arr) blk_p_buff(1:SIZE(blk_span)) = blk_span(:) blk_span(1:SIZE(blk_span)) = blk_p_buff(tmp_arr(1:SIZE(blk_span))) END DO !$OMP END DO ! DEALLOCATE (tmp_arr) DEALLOCATE (blk_p_buff) ! CALL timestop(error_handle) END SUBROUTINE merge_index