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