[1765] | 1 | MODULE scatter_add_m |
---|
| 2 | |
---|
| 3 | ! Bug correction: intent of "dest". |
---|
| 4 | |
---|
| 5 | IMPLICIT NONE |
---|
| 6 | |
---|
| 7 | INTERFACE scatter_add |
---|
| 8 | MODULE PROCEDURE scatter_add_r,scatter_add_d |
---|
| 9 | END INTERFACE |
---|
| 10 | |
---|
| 11 | private scatter_add_r,scatter_add_d |
---|
| 12 | |
---|
| 13 | CONTAINS |
---|
| 14 | |
---|
| 15 | SUBROUTINE scatter_add_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 | INTEGER :: m,n,j,i |
---|
| 21 | n=assert_eq(size(source),size(dest_index),'scatter_add_r') |
---|
| 22 | m=size(dest) |
---|
| 23 | do j=1,n |
---|
| 24 | i=dest_index(j) |
---|
| 25 | if (i > 0 .and. i <= m) dest(i)=dest(i)+source(j) |
---|
| 26 | end do |
---|
| 27 | END SUBROUTINE scatter_add_r |
---|
| 28 | |
---|
| 29 | SUBROUTINE scatter_add_d(dest,source,dest_index) |
---|
| 30 | use assert_eq_m, only: assert_eq |
---|
| 31 | DOUBLE PRECISION, DIMENSION(:), INTENT(inOUT) :: dest |
---|
| 32 | DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: source |
---|
| 33 | INTEGER, DIMENSION(:), INTENT(IN) :: dest_index |
---|
| 34 | INTEGER :: m,n,j,i |
---|
| 35 | n=assert_eq(size(source),size(dest_index),'scatter_add_d') |
---|
| 36 | m=size(dest) |
---|
| 37 | do j=1,n |
---|
| 38 | i=dest_index(j) |
---|
| 39 | if (i > 0 .and. i <= m) dest(i)=dest(i)+source(j) |
---|
| 40 | end do |
---|
| 41 | END SUBROUTINE scatter_add_d |
---|
| 42 | |
---|
| 43 | END MODULE scatter_add_m |
---|