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