1 |
|
|
MODULE SUTRLE_MOD |
2 |
|
|
CONTAINS |
3 |
|
|
SUBROUTINE SUTRLE(PNM) |
4 |
|
|
|
5 |
|
|
!**** *sutrle * - transposition of Legendre polynomials during set-up |
6 |
|
|
|
7 |
|
|
! Purpose. |
8 |
|
|
! -------- |
9 |
|
|
! transposition of Legendre polynomials during set-up |
10 |
|
|
|
11 |
|
|
!** Interface. |
12 |
|
|
! ---------- |
13 |
|
|
! *call* *sutrle(pnm) |
14 |
|
|
|
15 |
|
|
! Explicit arguments : |
16 |
|
|
! -------------------- |
17 |
|
|
|
18 |
|
|
! Implicit arguments : |
19 |
|
|
! -------------------- |
20 |
|
|
|
21 |
|
|
! Method. |
22 |
|
|
! ------- |
23 |
|
|
! See documentation |
24 |
|
|
|
25 |
|
|
! Externals. |
26 |
|
|
! ---------- |
27 |
|
|
|
28 |
|
|
! Reference. |
29 |
|
|
! ---------- |
30 |
|
|
! ECMWF Research Department documentation of the IFS |
31 |
|
|
|
32 |
|
|
! Author. |
33 |
|
|
! ------- |
34 |
|
|
! MPP Group *ECMWF* |
35 |
|
|
|
36 |
|
|
! Modifications. |
37 |
|
|
! -------------- |
38 |
|
|
! Original : 95-10-01 |
39 |
|
|
! ------------------------------------------------------------------ |
40 |
|
|
|
41 |
|
|
|
42 |
|
|
USE PARKIND1 ,ONLY : JPIM ,JPRB |
43 |
|
|
!USE MPL_MODULE |
44 |
|
|
|
45 |
|
|
USE TPM_GEN |
46 |
|
|
USE TPM_DIM |
47 |
|
|
USE TPM_DISTR |
48 |
|
|
USE TPM_FIELDS |
49 |
|
|
USE SET2PE_MOD |
50 |
|
|
USE ABORT_TRANS_MOD |
51 |
|
|
|
52 |
|
|
IMPLICIT NONE |
53 |
|
|
|
54 |
|
|
REAL(KIND=JPRB),INTENT(IN) :: PNM(R%NSPOLEG,D%NLEI3D) |
55 |
|
|
|
56 |
|
|
! LOCAL |
57 |
|
|
|
58 |
|
|
REAL(KIND=JPRB), ALLOCATABLE :: ZCOMBUF(:) |
59 |
|
|
REAL(KIND=JPRB), POINTER :: ZPNM(:,:) |
60 |
|
|
INTEGER(KIND=JPIM) :: IGLLOC, ILREC, IM, INENTR, IPOS, & |
61 |
|
|
&IRECSET, IRECV, ISEND, ISENDSET, ITAG, & |
62 |
|
|
&JGL, JGLLOC, JM, JMLOC, JN, JROC ,IOFFT, IOFFG |
63 |
|
|
|
64 |
|
|
LOGICAL :: LLADMSG, LLEXACT |
65 |
|
|
|
66 |
|
|
! ------------------------------------------------------------------ |
67 |
|
|
|
68 |
|
|
!* 0. Some initializations. |
69 |
|
|
! --------------------- |
70 |
|
|
!! Workaround for obscure unwillingness to vectorize on VPP |
71 |
|
|
ZPNM => F%RPNM |
72 |
|
|
|
73 |
|
|
! Perform barrier synchronisation to guarantee all processors have |
74 |
|
|
! completed all previous communication |
75 |
|
|
|
76 |
|
|
IF( NPROC > 1 )THEN |
77 |
|
|
! CALL GSTATS(783,0) ! MPL 3.12.08 |
78 |
|
|
! CALL MPL_BARRIER(CDSTRING='SUTRLE:') |
79 |
|
|
! CALL GSTATS(783,1) |
80 |
|
|
CALL ABOR1(' SUTRLE:A LA PLACE DE MPL_BARRIER') |
81 |
|
|
ENDIF |
82 |
|
|
|
83 |
|
|
ALLOCATE (ZCOMBUF(NCOMBFLEN)) |
84 |
|
|
|
85 |
|
|
DO JROC=1,NPRTRW-1 |
86 |
|
|
|
87 |
|
|
LLADMSG = .FALSE. |
88 |
|
|
ITAG = MTAGLETR |
89 |
|
|
|
90 |
|
|
!* Define PE to which data have to be sent and PE from which |
91 |
|
|
!* data have to be received |
92 |
|
|
|
93 |
|
|
! CALL GSTATS(801,0) ! MPL 4.12.08 |
94 |
|
|
ISEND = MYSETW-JROC |
95 |
|
|
IRECV = MYSETW+JROC |
96 |
|
|
IF (ISEND <= 0) ISEND = ISEND+NPRTRW |
97 |
|
|
IF (IRECV > NPRTRW) IRECV = IRECV-NPRTRW |
98 |
|
|
IRECSET = IRECV |
99 |
|
|
ISENDSET = ISEND |
100 |
|
|
CALL SET2PE(ISEND,0,0,ISEND,MYSETV) |
101 |
|
|
CALL SET2PE(IRECV,0,0,IRECV,MYSETV) |
102 |
|
|
|
103 |
|
|
!* copy data to be sent into zcombuf |
104 |
|
|
|
105 |
|
|
IPOS = 0 |
106 |
|
|
DO JM=0,R%NSMAX |
107 |
|
|
IF (ISENDSET == D%NPROCM(JM)) THEN |
108 |
|
|
INENTR = (D%NLATLE(MYSETW)-D%NLATLS(MYSETW)+1)*(R%NTMAX-JM+2) |
109 |
|
|
IF (IPOS + INENTR < NCOMBFLEN) THEN |
110 |
|
|
DO JGL=D%NLATLS(MYSETW),D%NLATLE(MYSETW) |
111 |
|
|
JGLLOC = JGL - D%NLATLS(MYSETW) + 1 |
112 |
|
|
DO JN=1,R%NTMAX-JM+2 |
113 |
|
|
IPOS = IPOS + 1 |
114 |
|
|
ZCOMBUF(IPOS) = PNM(D%NPMG(JM)+JN,JGLLOC) |
115 |
|
|
ENDDO |
116 |
|
|
ENDDO |
117 |
|
|
ELSE |
118 |
|
|
DO JGL=D%NLATLS(MYSETW),D%NLATLE(MYSETW) |
119 |
|
|
JGLLOC = JGL - D%NLATLS(MYSETW) + 1 |
120 |
|
|
DO JN=1,R%NTMAX-JM+2 |
121 |
|
|
IPOS = IPOS + 1 |
122 |
|
|
ZCOMBUF(IPOS) = PNM(D%NPMG(JM)+JN,JGLLOC) |
123 |
|
|
IF (IPOS == NCOMBFLEN) THEN |
124 |
|
|
! CALL MPL_SEND(zcombuf(1:ipos),KDEST=NPRCIDS(ISEND), & |
125 |
|
|
! & KTAG=ITAG,CDSTRING='SUTRLE:') ! MPL 3.12.08 |
126 |
|
|
CALL ABOR1(' SUTRLE:A LA PLACE DE MPL_SEND') |
127 |
|
|
IPOS = 0 |
128 |
|
|
ITAG = ITAG + 1 |
129 |
|
|
LLEXACT = (JGL == D%NLATLE(MYSETW) .AND. JN == R%NTMAX-JM+2) |
130 |
|
|
IF (.NOT.LLEXACT) LLADMSG = .TRUE. |
131 |
|
|
ENDIF |
132 |
|
|
ENDDO |
133 |
|
|
ENDDO |
134 |
|
|
ENDIF |
135 |
|
|
ENDIF |
136 |
|
|
ENDDO |
137 |
|
|
|
138 |
|
|
!* send message (if not empty or if message has been split) |
139 |
|
|
|
140 |
|
|
IF (IPOS > 0 .OR. LLADMSG) THEN |
141 |
|
|
! CALL MPL_SEND(ZCOMBUF(1:IPOS),KDEST=NPRCIDS(ISEND), & |
142 |
|
|
! & KTAG=ITAG,CDSTRING='SUTRLE:') ! MPL 3.12.08 |
143 |
|
|
CALL ABOR1(' SUTRLE:A LA PLACE DE MPL_SEND') |
144 |
|
|
ENDIF |
145 |
|
|
! CALL GSTATS(801,1) ! MPL 4.12.08 |
146 |
|
|
|
147 |
|
|
ILREC = 0 |
148 |
|
|
ITAG = MTAGLETR |
149 |
|
|
IF (D%NUMP > 0.AND. D%NLATLE(IRECSET) >= D%NLATLS(IRECSET)) THEN |
150 |
|
|
|
151 |
|
|
!* receive message (if not empty) |
152 |
|
|
|
153 |
|
|
! CALL GSTATS(801,0) |
154 |
|
|
! CALL MPL_RECV(ZCOMBUF(1:NCOMBFLEN),KSOURCE=NPRCIDS(IRECV), & |
155 |
|
|
! & KTAG=ITAG,KOUNT=ILREC,CDSTRING='SUTRLE:') ! MPL 3.12.08 |
156 |
|
|
CALL ABOR1(' SUTRLE:A LA PLACE DE MPL_RECV') |
157 |
|
|
|
158 |
|
|
!* copy data from buffer to f%rpnm |
159 |
|
|
|
160 |
|
|
IPOS = 0 |
161 |
|
|
DO JMLOC=1,D%NUMP |
162 |
|
|
JM = D%MYMS(JMLOC) |
163 |
|
|
INENTR = (D%NLATLE(IRECSET)-D%NLATLS(IRECSET)+1)*(R%NTMAX-JM+2) |
164 |
|
|
IOFFT = D%NPMT(JM) |
165 |
|
|
IF (IPOS + INENTR < NCOMBFLEN) THEN |
166 |
|
|
DO JGL=D%NLATLS(IRECSET),D%NLATLE(IRECSET) |
167 |
|
|
DO JN=1,R%NTMAX-JM+2 |
168 |
|
|
IPOS = IPOS + 1 |
169 |
|
|
ZPNM(JGL,IOFFT+JN) = ZCOMBUF(IPOS) |
170 |
|
|
ENDDO |
171 |
|
|
ENDDO |
172 |
|
|
ELSE |
173 |
|
|
DO JGL=D%NLATLS(IRECSET),D%NLATLE(IRECSET) |
174 |
|
|
DO JN=1,R%NTMAX-JM+2 |
175 |
|
|
IPOS = IPOS + 1 |
176 |
|
|
ZPNM(JGL,IOFFT+JN) = ZCOMBUF(IPOS) |
177 |
|
|
IF (IPOS == NCOMBFLEN) THEN |
178 |
|
|
ITAG = ITAG + 1 |
179 |
|
|
! CALL MPL_RECV(ZCOMBUF(1:NCOMBFLEN), & |
180 |
|
|
! & KSOURCE=NPRCIDS(IRECV),KTAG=ITAG, & |
181 |
|
|
! & KOUNT=ILREC,CDSTRING='SUTRLE:') ! MPL 3.12.08 |
182 |
|
|
CALL ABOR1(' SUTRLE:A LA PLACE DE MPL_RECV') |
183 |
|
|
IPOS = 0 |
184 |
|
|
ENDIF |
185 |
|
|
ENDDO |
186 |
|
|
ENDDO |
187 |
|
|
ENDIF |
188 |
|
|
ENDDO |
189 |
|
|
! CALL GSTATS(801,1) ! MPL 4.12.08 |
190 |
|
|
|
191 |
|
|
!* check received message length |
192 |
|
|
|
193 |
|
|
IF (ILREC /= IPOS) THEN |
194 |
|
|
WRITE(NOUT,*)' SUTRLE: ILREC,IPOS,NCOMBLEN ',ILREC,IPOS,NCOMBFLEN |
195 |
|
|
CALL ABORT_TRANS(' SUTRLE:RECEIVED MESSAGE LENGTH DOES NOT MATCH') |
196 |
|
|
ENDIF |
197 |
|
|
ENDIF |
198 |
|
|
|
199 |
|
|
! Perform barrier synchronisation to guarantee all processors have |
200 |
|
|
! completed communication for this jroc loop iteration |
201 |
|
|
|
202 |
|
|
! CALL MPL_BARRIER(CDSTRING='SUTRLE:') ! MPL 3.12.08 |
203 |
|
|
CALL ABOR1(' SUTRLE:A LA PLACE DE MPL_BARRIER') |
204 |
|
|
|
205 |
|
|
ENDDO |
206 |
|
|
|
207 |
|
|
!* copy data from pnm to rpnm |
208 |
|
|
|
209 |
|
|
!CALL GSTATS(1803,0) ! MPL 4.12.08 |
210 |
|
|
!cjfe OMP not efficient in that case |
211 |
|
|
!cjfe!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(jmloc,im,iofft,ioffg,jgl,iglloc,jn) |
212 |
|
|
DO JMLOC=1,D%NUMP |
213 |
|
|
IM = D%MYMS(JMLOC) |
214 |
|
|
IOFFT = D%NPMT(IM) |
215 |
|
|
IOFFG = D%NPMG(IM) |
216 |
|
|
DO JGL=D%NLATLS(MYSETW),D%NLATLE(MYSETW) |
217 |
|
|
IGLLOC = JGL-D%NLATLS(MYSETW)+1 |
218 |
|
|
DO JN=1,R%NTMAX-IM+2 |
219 |
|
|
ZPNM(JGL,IOFFT+JN) = PNM(IOFFG+JN,IGLLOC) |
220 |
|
|
ENDDO |
221 |
|
|
ENDDO |
222 |
|
|
ENDDO |
223 |
|
|
!cjfe!$OMP END PARALLEL DO |
224 |
|
|
!CALL GSTATS(1803,1) ! MPL 4.12.08 |
225 |
|
|
|
226 |
|
|
DEALLOCATE (ZCOMBUF) |
227 |
|
|
|
228 |
|
|
END SUBROUTINE SUTRLE |
229 |
|
|
END MODULE SUTRLE_MOD |