33
34
35
39
40
41
42#include "implicit_f.inc"
43
44
45
46#include "com04_c.inc"
47#include "scr17_c.inc"
48#include "scr15_c.inc"
49#include "units_c.inc"
50#include "scr03_c.inc"
51
52
53
54 INTEGER IPART(LIPART1,*), IXC(NIXC,*), IXTG(NIXTG,*),
55 . IPARTC(*), IPARTTG(*)
56 INTEGER , INTENT(INOUT) :: DYNAIN_CHECK
57
58
59
60 INTEGER I, J, K, N ,NELC , NELTG , IO_ERR1 , IP , NPRT ,
61 . FLG_CHK , IS_CHECK , JWARN, NELMIN , NELMAX , IPRT ,
62 . NELTGG , NELCG , IPRTALL , IERR2 ,IS_READ,
63 . DYNPART(NPART), IPART_DYNAIN(NPART)
64
65 INTEGER WORK(70000)
66 INTEGER , DIMENSION(:),ALLOCATABLE :: NELIDC ,NELIDTG,
67 . CLEFC ,CLEFTG ,INDXC ,INDXTG ,IDWARN ,NELIDCG ,NELIDTGG
69 CHARACTER FILNAM*109, KEYA*80, KEYA2*80
70 CHARACTER(LEN=NCHARLINE) ::CARTE
71 INTEGER :: LEN_TMP_NAME
72 CHARACTER(len=4096) :: TMP_NAME
73
74
75
76
77
78
79
80 filnam=rootnam(1:rootlen)//'_0001.rad'
83 OPEN(unit=71,file=tmp_name(1:len_tmp_name),
84 . access='SEQUENTIAL',status='OLD',iostat=io_err1)
85
86 IF (io_err1/=0) THEN
87 filnam=rootnam(1:rootlen)//'D01'
90 OPEN(unit=71,file=tmp_name(1:len_tmp_name),
91 . access='SEQUENTIAL',status='OLD',iostat=io_err1)
92 ENDIF
93
94 nelc = 0
95 neltg = 0
96 nprt = 0
97 iprtall = 0
98 is_read = 0
99 dynpart(1:npart) = 0
100 ipart_dynain(1:npart) = 0
101 IF (io_err1==0) THEN
102
10310 READ(71,'(A)',END=20) keya
104
105 IF(keya(1:1)=='#')GOTO 10
106 IF(keya(1:1)=='$')GOTO 10
107
108
109 dynain_check = 1
110
111 IF(keya(1:14)=='/DYNAIN/DT/ALL') THEN
112 IF(numelc/=0)THEN
113 ALLOCATE(nelidc(numelc),stat=ierr2)
114 DO i=1,numelc
115 nelidc(i) = ixc(nixc,i)
116 ENDDO
117 nelc = numelc
118 ENDIF
119 IF(numeltg/=0)THEN
120 ALLOCATE(nelidtg(numeltg),stat=ierr2)
121 DO i=1,numeltg
122 nelidtg(neltg) = ixtg(nixtg,i)
123 ENDDO
124 neltg = numeltg
125 ENDIF
126 nprt = npart
127 iprtall = 1
128
129 DO j=1,npart
130 ipart_dynain(j) = 1
131 END DO
132
133 is_read = 1
134
135 ELSEIF(keya(1:10)=='/DYNAIN/DT') THEN
136 READ(71,*,END=20) T0,dt0
137
138 READ(71,'(A)',END=20) carte
139 j=1
140 nprt = 0
141
142
143 IF(carte(1:1)/='#'.OR.carte(1:1)/='$') THEN
144 DO WHILE(carte(1:1) /= '/'.AND.len_trim(carte)/=0)
145 DO WHILE (j<=len_trim(carte))
146 IF(carte(j:j)/=' ') THEN
147 k=j
148 DO WHILE(carte(k:k)/=' '.AND.carte(k:k)/=char(13).AND.k<=len_trim(carte))
149 k=k+1
150 ENDDO
151 nprt = nprt + 1
152 READ(carte(j:k-1),'(I10)') iprt
153 dynpart(nprt) = iprt
154 j = k
155 ENDIF
156 j = j +1
157 ENDDO
158 READ(71,'(A)',END=20) carte
159 ENDDO
160 ENDIF
161 is_read = 1
162 ENDIF
163
164 GOTO 10
165
166 20 CONTINUE
167 CLOSE(71)
168
169 IF(is_read > 0 ) THEN
170 IF(nprt == 0)THEN
172 . msgtype=msgerror,
173 . anmode=aninfo_blind_1)
174
175 ELSEIF(iprtall ==0) THEN
176
177
178
179 DO i=1,nprt
180 ip=0
181 iprt = dynpart(i)
182 DO j=1,npart
183 IF(ipart(4,j)==iprt)ip=j
184 END DO
185 IF(ip==0)THEN
187 . msgtype=msgerror,
188 . anmode=aninfo_blind_1,
189 . i1=iprt)
190 END IF
191 ipart_dynain(ip)=1
192 ENDDO
193 IF(numelc/=0) ALLOCATE(nelidc(numelc),stat=ierr2)
194 IF(numeltg/=0) ALLOCATE(nelidtg(numeltg),stat=ierr2)
195
196 ENDIF
197
198
199
200 nelc = 0
201 DO i=1,numelc
202 ip = ipartc(i)
203 IF(ipart_dynain(ip)==1) THEN
204 nelc = nelc + 1
205 nelidc(nelc) = ixc(nixc,i)
206 ENDIF
207 ENDDO
208 neltg = 0
209 DO i=1,numeltg
210 ip = iparttg(i)
211 IF(ipart_dynain(ip)==1) THEN
212 neltg = neltg + 1
213 nelidtg(neltg) = ixtg(nixtg,i)
214 ENDIF
215 ENDDO
216
217 ENDIF
218
219
220 ENDIF
221
222 flg_chk = 0
223
224 IF(nelc/=0.AND.neltg/=0) flg_chk = 1
225
226 IF(flg_chk == 1 ) THEN
227 is_check = 0
228
229 ALLOCATE(clefc(nelc),stat=ierr2)
230 ALLOCATE(indxc(2*nelc),stat=ierr2)
231
232 DO n=1,nelc
233 indxc(n)=n
234 clefc(n)= nelidc(n)
235 END DO
236 CALL my_orders(0,work,clefc,indxc,nelc,1)
237
238 ALLOCATE(cleftg(neltg),stat=ierr2)
239 ALLOCATE(indxtg(2*neltg),stat=ierr2)
240
241 DO n=1,neltg
242 indxtg(n)=n
243 cleftg(n)= nelidtg(n)
244 END DO
245 CALL my_orders(0,work,cleftg,indxtg,neltg,1)
246
247 IF(nelidtg(indxtg(1))>=nelidc(indxc(1)).AND.nelidtg(indxtg(1))<=nelidc(indxc(nelc)))THEN
248 is_check = 1
249 ENDIF
250
251 IF(nelidtg(indxtg(neltg))>=nelidc(indxc(1)).AND.nelidtg(indxtg(neltg))<=nelidc(indxc(nelc)))THEN
252 is_check = 1
253 ENDIF
254
255 IF(nelidc(indxc(1))>=nelidtg(indxtg(1)).AND.nelidc(indxc(1))<=nelidtg(indxtg(neltg)))THEN
256 is_check = 1
257 ENDIF
258
259 IF(nelidc(indxc(nelc))>=nelidtg(indxtg(1)).AND.nelidc(indxc(nelc))<=nelidtg(indxtg(neltg)))THEN
260 is_check = 1
261 ENDIF
262
263 IF(is_check == 1) THEN
264 nelmin =
max(nelidc(indxc(1)),nelidtg(indxtg(1)))
265 nelmax =
min(nelidc(indxc(nelc)),nelidtg(indxtg(neltg)))
266
267 ALLOCATE(idwarn(
min(nelc,neltg)),stat=ierr2)
268 jwarn = 0
269 DO i=1,nelc
270 IF(nelidc(indxc(i))>=nelmin.AND.nelidc(indxc(i))<=nelmax) THEN
271 DO j=1,neltg
272 IF(nelidtg(indxtg(j))>=nelmin.AND.nelidtg(indxtg(j))<=nelmax) THEN
273 IF(nelidc(indxc(i))==nelidtg(indxtg(j))) THEN
274 jwarn = jwarn + 1
275 idwarn(jwarn) = nelidc(indxc(i))
276 ENDIF
277 ENDIF
278 ENDDO
279 ENDIF
280 ENDDO
281 IF(jwarn/=0)THEN
282 IF(ipri>=6)THEN
283
284 WRITE(iout,'(A,A)')
285 . ' ** ERROR : DYNAIN FILE CAN NOT BE WRITTEN',
286 . ' THESE 4 NODE SHELLS AND 3 NODE SHELLS HAVE SAME USER ID'
287 WRITE(iout,*) idwarn(1:jwarn)
288
290 . msgtype=msgerror,
291 . anmode=aninfo_blind_1,
292 . i1=jwarn)
293
294 ELSE
295
297 . msgtype=msgerror,
298 . anmode=aninfo_blind_1,
299 . i1=jwarn)
300
301 ENDIF
302 ENDIF
303 DEALLOCATE(idwarn)
304 ENDIF
305
306 DEALLOCATE(clefc,cleftg,indxc,indxtg)
307
308 ENDIF
309
310 IF(is_read > 0 ) THEN
311 IF(numelc/=0) DEALLOCATE(nelidc,stat=ierr2)
312 IF(numeltg/=0) DEALLOCATE(nelidtg,stat=ierr2)
313 ENDIF
314
315 RETURN
void my_orders(int *mode, int *iwork, int *data, int *index, int *n, int *irecl)
character(len=infile_char_len) infile_name
integer, parameter ncharline
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