[1765] | 1 | MODULE scatter_max_m |
---|
| 2 | |
---|
| 3 | ! Bug correction: intent of "dest". |
---|
| 4 | |
---|
| 5 | IMPLICIT NONE |
---|
| 6 | |
---|
| 7 | INTERFACE scatter_max |
---|
| 8 | MODULE PROCEDURE scatter_max_r, scatter_max_d |
---|
| 9 | END INTERFACE |
---|
| 10 | |
---|
| 11 | private scatter_max_r, scatter_max_d |
---|
| 12 | |
---|
| 13 | CONTAINS |
---|
| 14 | |
---|
| 15 | SUBROUTINE scatter_max_r(dest, source, dest_index) |
---|
| 16 | use assert_eq_m, only: assert_eq |
---|
| 17 | REAL, DIMENSION(:), INTENT(inOUT) :: dest |
---|
| 18 | REAL, DIMENSION(:), INTENT(IN) :: source |
---|
| 19 | INTEGER, DIMENSION(:), INTENT(IN) :: dest_index |
---|
| 20 | |
---|
| 21 | INTEGER :: m, n, j, i |
---|
| 22 | !-------------------------------------- |
---|
| 23 | n=assert_eq(size(source), size(dest_index), 'scatter_max_r') |
---|
| 24 | m=size(dest) |
---|
| 25 | do j=1, n |
---|
| 26 | i=dest_index(j) |
---|
| 27 | if (i > 0 .and. i <= m) dest(i)=max(dest(i), source(j)) |
---|
| 28 | end do |
---|
| 29 | END SUBROUTINE scatter_max_r |
---|
| 30 | |
---|
| 31 | !******************************************************* |
---|
| 32 | |
---|
| 33 | SUBROUTINE scatter_max_d(dest, source, dest_index) |
---|
| 34 | use assert_eq_m, only: assert_eq |
---|
| 35 | DOUBLE PRECISION, DIMENSION(:), INTENT(inOUT) :: dest |
---|
| 36 | DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: source |
---|
| 37 | INTEGER, DIMENSION(:), INTENT(IN) :: dest_index |
---|
| 38 | |
---|
| 39 | INTEGER :: m, n, j, i |
---|
| 40 | !-------------------------------------- |
---|
| 41 | n=assert_eq(size(source), size(dest_index), 'scatter_max_d') |
---|
| 42 | m=size(dest) |
---|
| 43 | do j=1, n |
---|
| 44 | i=dest_index(j) |
---|
| 45 | if (i > 0 .and. i <= m) dest(i)=max(dest(i), source(j)) |
---|
| 46 | end do |
---|
| 47 | END SUBROUTINE scatter_max_d |
---|
| 48 | |
---|
| 49 | END MODULE scatter_max_m |
---|