merge_index Subroutine

private subroutine merge_index(new_row_p, new_col_i, new_blk_p, 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)

Builds a new index from several work matrices.

Arguments

Type IntentOptional 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

Source Code

   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