38
39
40
43
44
45
46#include "implicit_f.inc"
47
48
49
50#include "com04_c.inc"
51#include "units_c.inc"
52#include "scr16_c.inc"
53#include "scr17_c.inc"
54#include "task_c.inc"
55#include "com01_c.inc"
56
57
58
59 INTEGER IPART(LIPART1,*), IXC(NIXC,*), IXTG(NIXTG,*),IPARTC(*), IPARTTG(*)
60 TYPE (DYNAIN_DATABASE)INTENT(INOUT) :: DYNAIN_DATA
61
62
63
64 INTEGER I,IDPRT,K_STAT,J,IP
65 INTEGER N ,NELC , NELTG , NELCG , NELTGG ,
66 . FLG_CHK , IS_CHECK , JWARN, NELMIN , NELMAX,
67 . MY_SIZEC ,MY_SIZETG ,IERR ,
68 . SIZEC_P0(NSPMD), SIZETG_P0(NSPMD) ,ADRC(NSPMD) ,
69 . ADRTG(NSPMD)
70
71 INTEGER WORK(70000)
72 INTEGER , DIMENSION(:),ALLOCATABLE :: NELIDC ,NELIDTG,
73 . CLEFC ,CLEFTG ,INDXC ,INDXTG ,IDWARN ,NELIDCG ,
74 . NELIDTGG
76 . t0,dt0
77
78 ALLOCATE( dynain_data%IPART_DYNAIN(npart))
79 dynain_data%IPART_DYNAIN(1:npart) = 0
80 IF (dynain_data%NDYNAINPRT /= 0) THEN
81 DO i=1,dynain_data%NDYNAINPRT
82 READ(iin,'(I10)') idprt
83 ip=0
84 DO j=1,npart
85 IF(ipart(4,j)==idprt)ip=j
86 END DO
87 IF(ip==0)THEN
88 CALL ancmsg(msgid=290,anmode=aninfo,i1=idprt)
90 END IF
91 dynain_data%IPART_DYNAIN(ip)=1
92 END DO
93 ELSEIF(dynain_data%NDYNAINALL /= 0) THEN
94 DO j=1,npart
95 dynain_data%IPART_DYNAIN(j) = 1
96 END DO
97 ENDIF
98
99
100
101
102
103 IF(dynain_data%DYNAIN_CHECK == 0.AND.(dynain_data%NDYNAINPRT /=0 .OR.dynain_data%NDYNAINALL /= 0) ) THEN
104
105 nelc = 0
106 neltg = 0
107 nelcg = 0
108 neltgg = 0
109
110 IF(numelc/=0) ALLOCATE(nelidc(numelc),stat=ierr)
111 IF(numeltg/=0) ALLOCATE(nelidtg(numeltg),stat=ierr)
112
113 IF(dynain_data%NDYNAINALL /= 0) THEN
114
115 IF(numelc/=0)THEN
116 DO i=1,numelc
117 nelidc(i) = ixc(nixc,i)
118 ENDDO
119 nelc = numelc
120 ENDIF
121 IF(numeltg/=0)THEN
122 DO i=1,numeltg
123 nelidtg(neltg) = ixtg(nixtg,i)
124 ENDDO
125 neltg = numeltg
126 ENDIF
127
128 ELSE
129 nelc = 0
130 DO i=1,numelc
131 ip = ipartc(i)
132 IF(dynain_data%IPART_DYNAIN(ip)==1) THEN
133 nelc = nelc + 1
134 nelidc(nelc) = ixc(nixc,i)
135 ENDIF
136 ENDDO
137 neltg = 0
138 DO i=1,numeltg
139 ip = iparttg(i)
140 IF(dynain_data%IPART_DYNAIN(ip)==1) THEN
141 neltg = neltg + 1
142 nelidtg(neltg) = ixtg(nixtg,i)
143 ENDIF
144 ENDDO
145
146 ENDIF
147
148
149 IF (nspmd > 1) THEN
150
151
152 sizec_p0(1:nspmd) = 0
153 adrc(1:nspmd) = 0
154
155
156 my_sizec = nelc
157
159
160 sizetg_p0(1:nspmd) = 0
161 adrtg(1:nspmd) = 0
162
163 my_sizetg = neltg
164
166
167 nelcg = 0
168 IF(ispmd==0) THEN
169 adrc(1) = 0
170 DO i=1,nspmd-1
171 adrc(i+1) = adrc(i) + sizec_p0(i)
172 nelcg = nelcg + sizec_p0(i)
173 ENDDO
174 nelcg = nelcg + sizec_p0(nspmd)
175 ENDIF
176
177 neltgg = 0
178 IF(ispmd==0) THEN
179 adrtg(1) = 0
180 DO i=1,nspmd-1
181 adrtg(i+1) = adrtg(i) + sizetg_p0(i)
182 neltgg = neltgg + sizetg_p0(i)
183 ENDDO
184 neltgg = neltgg + sizetg_p0(nspmd)
185 ENDIF
186
187 ALLOCATE(nelidcg(nelcg),stat=ierr)
188 ALLOCATE(nelidtgg(neltgg),stat=ierr)
189
190
191
193 . sizec_p0,adrc)
194
196 . sizetg_p0,adrtg)
197
198 ELSE
199 nelcg = nelc
200 neltgg = neltg
201 IF(nelcg/=0) THEN
202 ALLOCATE(nelidcg(nelcg),stat=ierr)
203 nelidcg(1:nelcg) = nelidc(1:nelc)
204 ENDIF
205 IF(neltgg/=0) THEN
206 ALLOCATE(nelidtgg(neltgg),stat=ierr)
207 nelidtgg(1:neltgg) = nelidtg(1:neltg)
208 ENDIF
209
210 ENDIF
211
212
213 IF(ispmd == 0) THEN
214
215 flg_chk = 0
216
217 IF(nelcg/=0.AND.neltgg/=0) flg_chk = 1
218
219 IF(flg_chk > 0 ) THEN
220
221 is_check = 0
222
223 ALLOCATE(clefc(nelcg),stat=ierr)
224 ALLOCATE(indxc(2*nelcg),stat=ierr)
225
226 DO n=1,nelcg
227 indxc(n)=n
228 clefc(n)= nelidcg(n)
229 END DO
230 CALL my_orders(0,work,clefc,indxc,nelcg,1)
231
232 ALLOCATE(cleftg(neltgg),stat=ierr)
233 ALLOCATE(indxtg(2*neltgg),stat=ierr)
234
235 DO n=1,neltgg
236 indxtg(n)=n
237 cleftg(n)= nelidtgg(n)
238 END DO
239
240 CALL my_orders(0,work,cleftg,indxtg,neltgg,1)
241
242 IF(nelidtgg(indxtg(1))>=nelidcg(indxc(1)).AND.nelidtgg(indxtg(1))<=nelidcg(indxc(nelcg)))THEN
243 is_check = 1
244 ENDIF
245
246 IF(nelidtgg(indxtg(neltgg))>=nelidcg(indxc(1)).AND.nelidtgg(indxtg(neltgg))<=nelidcg(indxc(nelcg)))THEN
247 is_check = 1
248 ENDIF
249
250 IF(nelidcg(indxc(1))>=nelidtgg(indxtg(1)).AND.nelidcg(indxc(1))<=nelidtgg(indxtg(neltgg)))THEN
251 is_check = 1
252 ENDIF
253
254 IF(nelidcg(indxc(nelcg))>=nelidtgg(indxtg(1)).AND.nelidcg(indxc(nelcg))<=nelidtgg(indxtg(neltgg)))THEN
255 is_check = 1
256 ENDIF
257
258 IF(is_check == 1) THEN
259 nelmin =
max(nelidcg(indxc(1)),nelidtgg(indxtg(1)))
260 nelmax =
min(nelidcg(indxc(nelcg)),nelidtgg(indxtg(neltgg)))
261
262 ALLOCATE(idwarn(
min(nelcg,neltgg)),stat=ierr)
263
264 jwarn = 0
265 DO i=1,nelcg
266 IF(nelidcg(indxc(i))>=nelmin.AND.nelidcg(indxc(i))<=nelmax) THEN
267 DO j=1,neltgg
268 IF(nelidtgg(indxtg(j))>=nelmin.AND.nelidtgg(indxtg(j))<=nelmax) THEN
269 IF(nelidcg(indxc(i))==nelidtgg(indxtg(j))) THEN
270 jwarn = jwarn + 1
271 idwarn(jwarn) = nelidcg(indxc(i))
272 ENDIF
273 ENDIF
274 ENDDO
275 ENDIF
276 ENDDO
277
278 IF(jwarn/=0)THEN
279 WRITE(iout,'(A,A)')
280 . ' ** ERROR : DYNAIN FILE CAN NOT BE WRITTEN',
281 . ' THESE 4 NODE SHELLS AND 3 NODE SHELLS HAVE SAME USER ID'
282 WRITE(iout,*) idwarn(1:jwarn)
283
284 WRITE(istdo,'(A,A,I10,A)')
285 . ' ** ERROR : DYNAIN FILE CAN NOT BE WRITTEN',
286 . ' 4 NODE SHELLS AND 3 NODE SHELLS MUST TO HAVE DIFFERENT USER ID',
287 . jwarn,'ERROR(S)'
289 ENDIF
290
291 DEALLOCATE(idwarn)
292
293 ENDIF
294
295 DEALLOCATE(clefc,cleftg,indxc,indxtg)
296
297 ENDIF
298 ENDIF
299
300 IF(numelc/=0) DEALLOCATE(nelidc,stat=ierr)
301 IF(numeltg/=0) DEALLOCATE(nelidtg,stat=ierr)
302 DEALLOCATE(nelidcg,nelidtgg)
303
304 ENDIF
305
306
307 RETURN
void my_orders(int *mode, int *iwork, int *data, int *index, int *n, int *irecl)
subroutine spmd_gather_int(sendbuf, recvbuf, proc, send_size, rcv_size)
subroutine spmd_gatherv_int(sendbuf, recvbuf, proc, send_size, total_rcv_size, rcv_size, dipls)
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
1.15.0