39
40
41
42 USE elbufdef_mod
43 USE my_alloc_mod
44 use element_mod , only : nixc,nixtg
45
46
47
48#include "implicit_f.inc"
49
50
51
52#include "com01_c.inc"
53#include "com04_c.inc"
54#include "param_c.inc"
55#include "remesh_c.inc"
56#include "scr16_c.inc"
57#include "scr17_c.inc"
58#include "units_c.inc"
59
60
61
62 INTEGER ITAB(*), ITABG(*), LENG, IPART(LIPART1,*),
63 . IGEO(NPROPGI,*), IXC(NIXC,*), IXTG(NIXTG,*),
64 . IPARTC(*), IPARTTG(*), IPART_STATE(*),
65 . NODTAG(*), STAT_INDXC(*), STAT_INDXTG(*),
66 . SH4TREE(KSH4TREE,*), SH3TREE(KSH3TREE,*),
67 . IPARG(NPARG,*), SH4TRIM(*), SH3TRIM(*),
68 . IDEL
69 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP), TARGET :: ELBUF_TAB
71 . thke(*)
72
73
74
75 INTEGER I, N, JJ, IPRT0, IPRT, K, II
76 INTEGER NG, NEL, NFT, LFT, LLT, ITY, MLW, ITHK,IOFF
77 INTEGER WORK(70000)
78 INTEGER, DIMENSION(:),ALLOCATABLE :: NP
79 INTEGER, DIMENSION(:,:),ALLOCATABLE :: CLEF
80 double precision,DIMENSION(:),ALLOCATABLE :: THK
81 TYPE(G_BUFEL_) ,POINTER :: GBUF
82
83 CALL my_alloc(thk,
max(numelc,numeltg))
84 CALL my_alloc(clef,2,
max(numelc,numeltg))
85 CALL my_alloc(np,8*
max(numelc,numeltg))
86
87
88
89 jj = 0
90 ii = 0
91 IF(numelc/=0)THEN
92
93 DO ng=1,ngroup
94 ity =iparg(5,ng)
95 IF(ity==3) THEN
96 nel =iparg(2,ng)
97 nft =iparg(3,ng)
98 gbuf => elbuf_tab(ng)%GBUF
99 mlw =iparg(1,ng)
100 ithk =iparg(28,ng)
101 lft=1
102 llt=nel
103 DO i=lft,llt
104 n = i + nft
105
106 iprt=ipartc(n)
107 IF(ipart_state(iprt)==0)cycle
108
109 np(jj+1) = ixc(nixc,n)
110 np(jj+2) = itab(ixc(2,n))
111 np(jj+3) = itab(ixc(3,n))
112 np(jj+4) = itab(ixc(4,n))
113 np(jj+5) = itab(ixc(5,n))
114 np(jj+6) = iprt
115 np(jj+7) = iabs(nint(gbuf%OFF(i)))
116 ii = ii + 1
117 IF (mlw /= 0 .AND. mlw /= 13) THEN
118 IF (ithk >0 ) THEN
119 thk(ii) = gbuf%THK(i)
120 ELSE
121 thk(ii) = thke(n)
122 END IF
123 ELSE
124 thk(ii) = zero
125 ENDIF
126 jj = jj + 7
127
128 stat_numelc =stat_numelc+1
129 clef(1,stat_numelc)=iprt
130 clef(2,stat_numelc)=ixc(nixc,n)
131
132 nodtag(ixc(2,n))=1
133 nodtag(ixc(3,n))=1
134 nodtag(ixc(4,n))=1
135 nodtag(ixc(5,n))=1
136
137 END DO
138 END IF
139 END DO
140 END IF
141
142 DO n=1,stat_numelc
143 stat_indxc(n)=n
144 END DO
145 CALL my_orders(0,work,clef,stat_indxc,stat_numelc,2)
146
147 iprt0=0
148 DO n=1,stat_numelc
149 k=stat_indxc(n)
150 jj=7*(k-1)
151 iprt=np(jj+6)
152 ioff=np(jj+7)
153 IF(idel==0.OR.(idel==1.AND.ioff >= 1)) THEN
154 IF(iprt /= iprt0)THEN
155 WRITE(iugeo,'(A,I10)')'/SHELL/',ipart(4,iprt)
156 WRITE(iugeo,'(A)')
157 . '# SHELLID NOD1 NOD2 NOD3 NOD4 THK'
158 iprt0=iprt
159 END IF
160 WRITE(iugeo,'(5I10,30X,1PE20.13)')
161 . np(jj+1),np(jj+2),np(jj+3),np(jj+4),np(jj+5),thk(k)
162 ENDIF
163 END DO
164
165
166 IF(nadmesh /=0)THEN
167 jj = 0
168 IF(numelc/=0)THEN
169 DO ng=1,ngroup
170 ity =iparg(5,ng)
171 IF(ity==3) THEN
172 nel =iparg(2,ng)
173 nft =iparg(3,ng)
174 lft=1
175 llt=nel
176 DO i=lft,llt
177 n = i + nft
178
179 iprt=ipartc(n)
180 IF(ipart_state(iprt)==0)cycle
181
182 np(jj+1) = ixc(nixc,n)
183 IF(sh4tree(2,n) /= 0)THEN
184 np(jj+2) = ixc(nixc,sh4tree(2,n) )
185 np(jj+3) = ixc(nixc,sh4tree(2,n)+1)
186 np(jj+4) = ixc(nixc,sh4tree(2,n)+2)
187 np(jj+5) = ixc(nixc,sh4tree(2,n)+3)
188 ELSE
189 np(jj+2) =0
190 np(jj+3) =0
191 np(jj+4) =0
192 np(jj+5) =0
193 END IF
194 np(jj+6) = sh4tree(3,n)
195 np(jj+7) = iprt
196 IF(lsh4trim /= 0)THEN
197 IF(sh4trim(n)==-1)THEN
198 np(jj+8) = -1
199 ELSE
200 np(jj+8) = 0
201 END IF
202 ELSE
203 np(jj+8) = 0
204 END IF
205 jj = jj + 8
206 END DO
207 END IF
208 END DO
209 END IF
210
211 iprt0=0
212 DO n=1,stat_numelc
213 k=stat_indxc(n)
214 jj=8*(k-1)
215 iprt=np(jj+7)
216 IF(iprt /= iprt0)THEN
217 WRITE(iugeo,'(A)')'/ADMESH/STATE/SHELL'
218 WRITE(iugeo,'(2A)')
219 . '# SHELLID ID1 ID2 ID3 ID4 LEVEL',
220 . ' IMAPPING'
221 iprt0=iprt
222 END IF
223 WRITE(iugeo,'(7I10)')
224 . np(jj+1),np(jj+2),np(jj+3),np(jj+4),np(jj+5),np(jj+6),np(jj+8)
225 END DO
226
227 END IF
228
229
230
231 jj = 0
232 ii = 0
233 IF(numeltg/=0)THEN
234 DO ng=1,ngroup
235 ity =iparg(5,ng)
236 IF(ity==7) THEN
237 nel =iparg(2,ng)
238 nft =iparg(3,ng)
239 gbuf => elbuf_tab(ng)%GBUF
240 mlw =iparg(1,ng)
241 ithk =iparg(28,ng)
242 lft=1
243 llt=nel
244
245 DO i=lft,llt
246 n = i + nft
247
248 iprt=iparttg(n)
249 IF(ipart_state(iprt)==0)cycle
250
251 np(jj+1) = ixtg(nixtg,n)
252 np(jj+2) = itab(ixtg(2,n))
253 np(jj+3) = itab(ixtg(3,n))
254 np(jj+4) = itab(ixtg(4,n))
255 np(jj+5) = iprt
256 np(jj+6) = iabs(nint(gbuf%OFF(i)))
257 ii = ii + 1
258 IF (mlw /= 0 .AND. mlw /= 13) THEN
259 IF (ithk >0 ) THEN
260 thk(ii) = gbuf%THK(i)
261 ELSE
262 thk(ii) = thke(n)
263 END IF
264 ELSE
265 thk(ii) = zero
266 ENDIF
267 jj = jj + 6
268
269 stat_numeltg =stat_numeltg+1
270 clef(1,stat_numeltg)=iprt
271 clef(2,stat_numeltg)=ixtg(nixtg,n)
272
273 nodtag(ixtg(2,n))=1
274 nodtag(ixtg(3,n))=1
275 nodtag(ixtg(4,n))=1
276
277 END DO
278 END IF
279 END DO
280 END IF
281
282
283 DO n=1,stat_numeltg
284 stat_indxtg(n)=n
285 END DO
286 CALL my_orders(0,work,clef,stat_indxtg,stat_numeltg,2)
287
288 iprt0=0
289 DO n=1,stat_numeltg
290 k=stat_indxtg(n)
291 jj=6*(k-1)
292 iprt=np(jj+5)
293 ioff=np(jj+6)
294 IF(idel==0.OR.(idel==1.AND.ioff >= 1)) THEN
295 IF(iprt /= iprt0)THEN
296 WRITE(iugeo,'(A,I10)')'/SH3N/',ipart(4,iprt)
297 WRITE(iugeo,'(A)')
298 . '# SH3NID NOD1 NOD2 NOD3 THK'
299 iprt0=iprt
300 END IF
301 WRITE(iugeo,'(4I10,40X,1PE20.13)')
302 . np(jj+1),np(jj+2),np(jj+3),np(jj+4),thk(k)
303 ENDIF
304 END DO
305
306
307 IF(nadmesh /=0)THEN
308 jj = 0
309 IF(numeltg/=0)THEN
310
311 DO ng=1,ngroup
312 ity =iparg(5,ng)
313 IF(ity==7) THEN
314 nel =iparg(2,ng)
315 nft =iparg(3,ng)
316 lft=1
317 llt=nel
318
319 DO i=lft,llt
320 n = i + nft
321
322 iprt=iparttg(n)
323 IF(ipart_state(iprt)==0)cycle
324
325 np(jj+1) = ixtg(nixtg,n)
326 IF(sh3tree(2,n) /= 0)THEN
327 np(jj+2) = ixtg(nixtg,sh3tree(2,n) )
328 np(jj+3) = ixtg(nixtg,sh3tree(2,n)+1)
329 np(jj+4) = ixtg(nixtg,sh3tree(2,n)+2)
330 np(jj+5) = ixtg(nixtg,sh3tree(2,n)+3)
331 ELSE
332 np(jj+2) =0
333 np(jj+3) =0
334 np(jj+4) =0
335 np(jj+5) =0
336 END IF
337 np(jj+6) = sh3tree(3,n)
338 np(jj+7) = iprt
339 IF(lsh3trim /= 0)THEN
340 IF(sh3trim(n)==-1)THEN
341 np(jj+8) = -1
342 ELSE
343 np(jj+8) = 0
344 END IF
345 ELSE
346 np(jj+8) = 0
347 END IF
348 jj = jj + 8
349 END DO
350 END IF
351 END DO
352 END IF
353
354 iprt0=0
355 DO n=1,stat_numeltg
356 k=stat_indxtg(n)
357 jj=8*(k-1)
358 iprt=np(jj+7)
359 IF(iprt /= iprt0)THEN
360 WRITE(iugeo,'(A)')'/ADMESH/STATE/SH3N'
361 WRITE(iugeo,'(2A)')
362 . '# SH3NID ID1 ID2 ID3 ID4 LEVEL',
363 . ' IMAPPING'
364 iprt0=iprt
365 END IF
366 WRITE(iugeo,'(7I10)')
367 . np(jj+1),np(jj+2),np(jj+3),np(jj+4),np(jj+5),np(jj+6),np(jj+8)
368 END DO
369
370 END IF
371
372 DEALLOCATE(thk)
373 DEALLOCATE(clef)
374 DEALLOCATE(np)
375 RETURN
void my_orders(int *mode, int *iwork, int *data, int *index, int *n, int *irecl)
1.15.0