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