UPP (develop)
Loading...
Searching...
No Matches
COLLECT_LOC.f
Go to the documentation of this file.
1
16!--------------------------------------------------------------------------------
21!--------------------------------------------------------------------------------
22 SUBROUTINE collect_loc ( A, B )
23
24
25 use ctlblk_mod, only: num_procs, jsta, icnt, idsp, mpi_comm_comp, im,&
26 jsta_2l, jend_2u, jm, me, &
27 buff,ista_2l,iend_2u,jexa,iexa,jsxa,isxa,ista,iend
28!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
29 implicit none
30!
31 include 'mpif.h'
32 integer ii,jj,isum
33 real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(in) :: a
34 real, dimension(im,jm), intent(out) :: b
35 integer ierr,n
36 real, allocatable :: rbufs(:)
37 allocate(buff(im*jm))
38 jj=( jexa(me)-jsxa(me)+1) * (iexa(me)-isxa(me)+1)
39 allocate( rbufs(( jexa(me)-jsxa(me)+1) * (iexa(me)-isxa(me)+1)) )
40!
41 if ( num_procs <= 1 ) then
42 b = a
43 else
44
45!GWV reshape the receive subdomain
46
47 isum=1
48 do jj=jsxa(me),jexa(me)
49 do ii=isxa(me),iexa(me)
50 if(isum .gt. im*jm .or. ii .gt. im .or. ii .lt. 1 .or. jj .gt. jm .or. jj.lt. 1) &
51 write(*,901)' BOUNDS2 FAIL in reshape ',isum,ii,jj,im*jm,im,im*jm
52 rbufs(isum)=a(ii,jj)
53 isum=isum+1
54 end do
55 end do
56
57!GWV end reshape
58
59 call mpi_gatherv(rbufs,icnt(me),mpi_real, buff,icnt,idsp,mpi_real,0,mpi_comm_world, ierr )
60
61!GWV reshape the gathered array
62
63 if(me .eq. 0) then
64 isum=1
65 do n=0,num_procs-1
66 do jj=jsxa(n),jexa(n)
67 do ii=isxa(n),iexa(n)
68 if(isum .gt. im*jm .or. ii .gt. im .or. ii .lt. 1 .or. jj .gt. jm .or. jj .lt. 1) &
69 write(*,901)' BOUNDS FAIL in reshape ',isum,ii,jj,im*jm,im,im*jm
70 b(ii,jj)=buff(isum)
71 isum=isum+1
72 end do
73 end do
74 end do
75 end if
76
77 endif ! num_procs <= 1
78
79 901 format(a30,10i10)
80
81 deallocate(buff)
82 deallocate(rbufs)
83
84 end
85!
86!-----------------------------------------------------------------------
91!-----------------------------------------------------------------------
92!
93 SUBROUTINE collect_all ( A, B )
94
95 use ctlblk_mod, only: num_procs, jsta, icnt, idsp, mpi_comm_comp, im,&
96 jsta_2l, jend_2u, jm, me, &
97 buff,ista_2l,iend_2u,jexa,iexa,jsxa,isxa,ista,iend,jend
98!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
99 implicit none
100!
101 include 'mpif.h'
102 integer ii,jj,isum
103 real, dimension(ista:iend,jsta:jend), intent(in) :: a
104 real, dimension(im,jm), intent(out) :: b
105 integer ierr,n
106 real, allocatable :: rbufs(:)
107 allocate(buff(im*jm))
108 jj=( jexa(me)-jsxa(me)+1) * (iexa(me)-isxa(me)+1)
109 allocate( rbufs(( jexa(me)-jsxa(me)+1) * (iexa(me)-isxa(me)+1)) )
110!
111 if ( num_procs <= 1 ) then
112 b = a
113 else
114
115!GWV reshape the receive subdomain
116 isum=1
117 do jj=jsxa(me),jexa(me)
118 do ii=isxa(me),iexa(me)
119 if(isum .gt. im*jm .or. ii .gt. im .or. ii .lt. 1 .or. jj .gt. jm .or. jj.lt. 1) &
120 write(*,901)' BOUNDS2 FAIL in reshape',isum,ii,jj,im*jm,im,im*jm
121 rbufs(isum)=a(ii,jj)
122 isum=isum+1
123 end do
124 end do
125!GWV end reshape
126
127 call mpi_allgatherv(rbufs,icnt(me),mpi_real,buff,icnt,idsp,mpi_real, mpi_comm_comp, ierr )
128 call mpi_barrier(mpi_comm_comp,ierr)
129
130!GWV reshape the gathered array and collect in all procs
131 isum=1
132 do n=0,num_procs-1
133 do jj=jsxa(n),jexa(n)
134 do ii=isxa(n),iexa(n)
135 if(isum .gt. im*jm .or. ii .gt. im .or. ii .lt. 1 .or. jj .gt. jm .or. jj .lt. 1) &
136 write(*,901)' BOUNDS FAIL in reshape',isum,ii,jj,im*jm,im,im*jm
137 b(ii,jj)=buff(isum)
138 isum=isum+1
139 end do
140 end do
141 end do
142
143 endif ! num_procs <= 1
144
145 901 format(a30,10i10)
146
147 deallocate(buff)
148 deallocate(rbufs)
149
150 end
151
subroutine collect_all(a, b)
COLLECT_ALL()
Definition COLLECT_LOC.f:94
subroutine collect_loc(a, b)
COLLECT_LOC.
Definition COLLECT_LOC.f:23