OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
genani1.F File Reference
#include "implicit_f.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "com09_c.inc"
#include "sphcom.inc"
#include "param_c.inc"
#include "units_c.inc"
#include "scr14_c.inc"
#include "scr15_c.inc"
#include "scr16_c.inc"
#include "scr12_c.inc"
#include "scr17_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine genani1 (x, bufel, ixs, ixq, ixc, ixt, ixp, ixr, ixtg, swaft, iparg, pm, geo, skew, itab, lpby, npby, nstrf, rwbuf, nprw, ipart, iparts, ipartq, ipartc, ipartt, ipartp, ipartr, iparttg, rby, swa4, igrsurf, bufsf, ipartx, kxsp, ixsp, ipartsp, spbuf, ixs10, ixs20, ixs16, ipm, igeo, smater, sel2fa, snfacptx, sixedge, soffx1, snumx1, sxnorm, sinvert, sfunc1, siad, nmanim, d, smas, ms, fxani, mbufel, mdepl, nlevel, elsub, dsanim, nelem, cep, cepsp, nom_opt, ptr_nopt_rwall, ptr_nopt_sect, elbuf_tab, sph2sol, subset)
subroutine xyz16 (ixs, ixs10, ixs20, ixs16, x)
subroutine xyznor16 (ixs, ixs10, ixs20, ixs16, x)

Function/Subroutine Documentation

◆ genani1()

subroutine genani1 ( x,
bufel,
integer, dimension(nixs,*) ixs,
integer, dimension(nixq,*) ixq,
integer, dimension(nixc,*) ixc,
integer, dimension(nixt,*) ixt,
integer, dimension(nixp,*) ixp,
integer, dimension(nixr,*) ixr,
integer, dimension(nixtg,*) ixtg,
integer swaft,
integer, dimension(nparg,*) iparg,
pm,
geo,
skew,
integer, dimension(*) itab,
integer, dimension(*) lpby,
integer, dimension(nnpby,*) npby,
integer, dimension(*) nstrf,
rwbuf,
integer, dimension(*) nprw,
integer, dimension(lipart1,*) ipart,
integer, dimension(*) iparts,
integer, dimension(*) ipartq,
integer, dimension(*) ipartc,
integer, dimension(*) ipartt,
integer, dimension(*) ipartp,
integer, dimension(*) ipartr,
integer, dimension(*) iparttg,
rby,
integer swa4,
type (surf_), dimension(nsurf) igrsurf,
bufsf,
integer, dimension(*) ipartx,
integer, dimension(nisp,*) kxsp,
integer, dimension(kvoisph,*) ixsp,
integer, dimension(*) ipartsp,
spbuf,
integer, dimension(6,*) ixs10,
integer, dimension(12,*) ixs20,
integer, dimension(8,*) ixs16,
integer, dimension(npropmi,*) ipm,
integer, dimension(npropgi,*) igeo,
integer smater,
integer sel2fa,
integer snfacptx,
integer sixedge,
integer soffx1,
integer snumx1,
integer sxnorm,
integer sinvert,
integer sfunc1,
integer siad,
integer nmanim,
d,
integer smas,
ms,
integer, dimension(2,*) fxani,
mbufel,
mdepl,
integer nlevel,
integer, dimension(nlevel,*) elsub,
integer dsanim,
integer nelem,
integer, dimension(*) cep,
integer, dimension(*) cepsp,
integer, dimension(lnopt1,*) nom_opt,
integer ptr_nopt_rwall,
integer ptr_nopt_sect,
type (elbuf_struct_), dimension(ngroup) elbuf_tab,
integer, dimension(*) sph2sol,
type (subset_), dimension(nsubs) subset )

Definition at line 82 of file genani1.F.

98C-----------------------------------------------
99C M o d u l e s
100C-----------------------------------------------
101 USE fvbag_mod
102 USE message_mod
103 USE elbufdef_mod
104 USE groupdef_mod
105 USE inoutfile_mod
106 USE names_and_titles_mod , ONLY : nchartitle
107 use element_mod , only : nixs,nixq,nixc,nixt,nixp,nixr,nixtg
108C-----------------------------------------------
109C I m p l i c i t T y p e s
110C-----------------------------------------------
111#include "implicit_f.inc"
112C-----------------------------------------------
113C C o m m o n B l o c k s
114C-----------------------------------------------
115#include "com01_c.inc"
116#include "com04_c.inc"
117#include "com09_c.inc"
118#include "sphcom.inc"
119#include "param_c.inc"
120#include "units_c.inc"
121#include "scr14_c.inc"
122#include "scr15_c.inc"
123#include "scr16_c.inc"
124#include "scr12_c.inc"
125#include "scr17_c.inc"
126C-----------------------------------------------
127C D u m m y A r g u m e n t s
128C-----------------------------------------------
129 INTEGER IXS(NIXS,*), IXQ(NIXQ,*), IXC(NIXC,*), IXT(NIXT,*),
130 . IXP(NIXP,*), IXR(NIXR,*), IXTG(NIXTG,*), SWAFT,
131 . IPARG(NPARG,*), ITAB(*), LPBY(*), NPBY(NNPBY,*),
132 . NSTRF(*), NPRW(*), IPART(LIPART1,*),
133 . IPARTS(*), IPARTQ(*), IPARTC(*), IPARTT(*),
134 . IPARTP(*), IPARTR(*), IPARTTG(*),SWA4,
135 . IPARTX(*), KXSP(NISP,*),IXSP(KVOISPH,*),
136 . IPARTSP(*), IXS10(6,*), IXS20(12,*), IXS16(8,*),
137 . IPM(NPROPMI,*), IGEO(NPROPGI,*), SMATER, SEL2FA,
138 . SNFACPTX, SIXEDGE, SOFFX1, SNUMX1, SXNORM, SINVERT,
139 . SFUNC1, SIAD, NMANIM, SMAS, FXANI(2,*),
140 . NLEVEL, ELSUB(NLEVEL,*),DSANIM, NELEM, CEP(*), CEPSP(*),
141 . SPH2SOL(*)
142 INTEGER NOM_OPT(LNOPT1,*),PTR_NOPT_RWALL,PTR_NOPT_SECT
143C
144 my_real
145 . x(3,*), bufel(*), pm(npropm,*), geo(npropg,*),
146 . skew(lskew,*), rwbuf(nrwlp,*), rby(nrby,*), bufsf(*),
147 . spbuf(*), d(3,*), ms(*), mbufel(lbufel,*),
148 . mdepl(3*numnod,*)
149 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP) :: ELBUF_TAB
150C-----------------------------------------------
151 TYPE (SUBSET_) , DIMENSION(NSUBS) :: SUBSET
152 TYPE (SURF_) , DIMENSION(NSURF) :: IGRSURF
153C-----------------------------------------------
154C L o c a l V a r i a b l e s
155C-----------------------------------------------
156 INTEGER LTITL, ISPH3D, I161, I16A, I16B, I16C, I16D, I16E, I16F,
157 . I16G, I16H, I16I, FILEN, CTEXT(200), NSKEWA, NB1D, I,
158 . MATER(SMATER), NBPART, NBF, NBF_L, EL2FA(SEL2FA), NODCUT,
159 . NELCUT, NCUTS, NUMSPH_T, NESCT, NERWL, NNWL, NESBW2,
160 . NESRG, NNSRG, NSURG, NESMD, NNSMD, NSMAD, NESPH, NNSPH,
161 . NNSPHG, NUMELS_T, NUMELS16_T, NUMELT_T, NUMELR_T,
162 . NUMELP_T, MAGIC, IFLAG1D, BUFL, SNNSPHG, SZ16,
163 . BUF, NESCT1, NERWL1, ISECT, IRWL, NESRG1, ISRG, NESMD1,
164 . J, IB, NDMA2, IFUNC, SZNNSPH, SHFTSPH, SHFT16, INSPH, NNN,
165 . NERBY, NB1D_T, IPRT, NERBT(NRBODY), NERBY1, IRBY, LRBUF,
166 . NFACPTX(3,SNFACPTX), IXEDGE(SIXEDGE),
167 . IAD(SIAD), IOFFX1(SOFFX1), INUMX1(SNUMX1), MXSUBS, N1, N2,
168 . N3, K, M3, M4, N0, NESPHG, ISRF, INVERT(SINVERT), M01,
169 . M1, M2, NNNSRG, M, N, LID, NMFUNC(9)
170 INTEGER FVOFF(2,NFVBAG), INOD(4), INORM(3), NFVTR, NFVNOD,
171 . NFVPART, NFVSUBS, IDMAX, KK, NN, FVIAD, JJ, OFFPART,
172 . ELOFF, IDCMAX, NND, NBID1, NBID2, NBID3, NFVNODT, IDP,
173 . NBPART2D, IDPART2DMAX, II
174 INTEGER, DIMENSION(:), ALLOCATABLE :: OFFTR, ITAGT, FVEL2FA,
175 . FVINUM, FVPBUF
176C
177 my_real
178 . cdg(3), waft(swaft), xmin, ymin, zmin, xmax, ymax, zmax,
179 . xnorm(sxnorm), xfunc1(sfunc1), mas(smas), rid
180 REAL R4, WA4(SWA4)
181 CHARACTER FILNAM*103, CHANIM*3, CHANIM1*4, CTMOD*100
182 CHARACTER*80 STR
183 CHARACTER(LEN=NCHARTITLE) :: TITL
184Cf51e11 +2
185 INTEGER OFF
186 my_real
187 . func(max(nelem,numsph))
188 CHARACTER*33 CTITR(MAX(1,NLEVEL))
189 CHARACTER*80 STRZZ
190C
191 ltitl = 40
192C ENDIF
193 IF(anim_vers<44)THEN
194 isph3d=1
195 ELSE
196 isph3d=0
197 ENDIF
198 i161=1
199 i16a=i161+lnopt1*nrbody
200 i16b=i16a+lnopt1*naccelm
201 i16c=i16b+lnopt1*nvolu
202 i16d=i16c+lnopt1*(ninter+nintsub)
203 i16e=i16d+lnopt1*nrwall
204 i16f=i16e !obsolete option removed
205 i16g=i16f+lnopt1*njoint
206 i16h=i16g+lnopt1*nsect
207 i16i=i16h+lnopt1*nlink
208 mas(1:smas) = zero
209C-----------------------------------------------
210C OPEN FILE
211C-----------------------------------------------
212 IF(anim_vers>=50)THEN
213 IF(ianim>=10000)ianim=1
214 WRITE(chanim1,'(I4.4)')ianim
215 filnam=outfile_name(1:outfile_name_len)//
216 . rootnam(1:rootlen)//'_'//chanim1//'.ani'
217 filen = outfile_name_len + rootlen + 9
218 ELSE
219 IF(ianim>=1000)ianim=1
220 WRITE(chanim,'(I3.3)')ianim
221 filnam=outfile_name(1:outfile_name_len)//
222 . rootnam(1:rootlen)//'A'//chanim
223 filen = outfile_name_len + rootlen + 4
224 ENDIF
225C
226 DO i=1,filen
227 ctext(i)=ichar(filnam(i:i))
228 ENDDO
229 CALL cur_fil_c(0)
230 CALL open_c(ctext,filen,0)
231C-----------------------------------------------
232C ANIM MULTI-LEVEL DOMDEC
233C-----------------------------------------------
234 WRITE(ctitr(1),'(A25)') 'SPMD Domain Decomposition'
235 DO i=2,nlevel
236 WRITE(ctitr(i),'(A30,I3)') 'Impl. graph - Dom. Dec. Level ',i
237 ENDDO
238C-----------------------------------------------
239C SKEW + NB1D
240C NB1D includes all 1D elements except those from X-ELEMENTS.
241C-----------------------------------------------
242 nskewa=numelp + numelt + numskw
243 nb1d =numelp + numelt + numelr
244 DO i=1,numelr
245 IF(nint(geo(12,ixr(1,i)))==4 .OR.
246 . nint(geo(12,ixr(1,i)))==13.OR.
247 . nint(geo(12,ixr(1,i)))==45.OR.
248 . (nint(geo(12,ixr(1,i)))>=29.AND.
249 . nint(geo(12,ixr(1,i)))<=33))THEN
250 nskewa=nskewa+1
251 ELSEIF(nint(geo(12,ixr(1,i)))==12)THEN
252 nskewa=nskewa+2
253 nb1d =nb1d+1
254 ENDIF
255 ENDDO
256C=======================================================================
257C
258C COQUE 3N 4N
259C
260C=======================================================================
261 DO i=1,npart
262 mater(i)=0
263 ENDDO
264 DO i=1,numelq
265 mater(ipartq(i))=1
266 ENDDO
267 DO i=1,numelc
268 mater(ipartc(i))=1
269 ENDDO
270 DO i=1,numeltg
271 mater(iparttg(i))=1
272 ENDDO
273C
274 nbpart = 0
275 DO i=1,npart
276 nbpart = nbpart + mater(i)
277 ENDDO
278C
279 nbf = numelq + numelc + numeltg
280 nbf_l = nbf
281C
282 DO i=1,numelq + numelc + numeltg + 1
283 el2fa(i)=0
284 ENDDO
285C-----------------------------------------------
286C SECTIONS IN SOLIDS
287C-----------------------------------------------
288 nodcut=0
289 nelcut=0
290 ncuts=0
291C-----------------------------------------------
292 numsph_t = numsph
293 nesct = 0
294 nerwl = 0
295 nnwl = 0
296 nesbw2= 0
297 IF(nsect+nrwall>0) THEN
298 CALL dseccnt(nesct,nerwl,nesbw2,nstrf,
299 1 rwbuf ,nprw,nnwl,ixs)
300 END IF
301
302 nesrg=0
303 nnsrg=0
304 nsurg=0
305 IF (nsurf>0)
306 . CALL dsrgcnt(igrsurf, nsurg,nesrg,nnsrg,nesbw2)
307 nesmd=0
308 nnsmd=0
309 nsmad=0
310 nesph=0
311 nnsph=0
312 nnsphg = 0
313 IF (isph3d==1.AND.numsph_t+maxpjet>0)
314 . CALL dsphcnt(nesph,nnsph,nesphg,nnsphg)
315C-----------------------------------------------
316C MAILLAGE VOLUMES FINIS POUR FVMBAG
317C-----------------------------------------------
318 nfvnod=0
319 nfvtr=0
320 nfvpart=0
321 nfvsubs=0
322 IF (nfvbag>0) THEN
323 idmax=0
324 DO i=1,numnod
325 idmax=max(idmax,itab(i))
326 ENDDO
327 ENDIF
328C
329 IF (ifvani==1) THEN
330 DO i=1,nfvbag
331 nfvtr=nfvtr+fvdata(i)%NNTR
332 fvoff(1,i)=numnod+nodcut+nsect+nrwall+nnwl
333 . +nnsrg+nnsmd+nnsph+2*numels16+nfvnod
334 fvoff(2,i)=idmax+nfvnod
335 nfvnod=nfvnod+fvdata(i)%NNS_ANIM
336 nfvpart=nfvpart+fvdata(i)%NPOLH_ANIM
337 nfvsubs=nfvsubs+1
338 ENDDO
339 ENDIF
340C
341 IF (nfvtr>0)
342 . ALLOCATE(fvel2fa(nfvtr), fvinum(nfvtr))
343C
344C-----------------------------------------------
345C WRITE CONTROL
346C-----------------------------------------------
347 numels_t = numels
348 numels16_t = numels16
349 numelt_t = numelt
350 numelr_t = numelr
351 numelp_t = numelp
352C
353 magic = 21548
354 CALL write_i_c(magic,1)
355 r4=ianim
356 CALL write_r_c(r4,1)
357 CALL ani_txt('Mode number=',12)
358 CALL ani_txt('Local mode',10)
359 CALL ani_txt('Radioss Run=',12)
360C
361 CALL write_i_c(anim_m,1)
362 CALL write_i_c(1,1)
363C
364 IF(numels_t+isph3d*(numsph_t+maxpjet)==0) THEN
365 CALL write_i_c(0,1)
366 ELSE
367 CALL write_i_c(1,1)
368 ENDIF
369 iflag1d = numelt_t+numelp_t+numelr_t+nanim1d+nrbody
370 IF (iflag1d/=0) iflag1d = 1
371 CALL write_i_c(iflag1d,1)
372C
373C HIERARCHY
374 CALL write_i_c(1,1)
375C TH
376 CALL write_i_c(0,1)
377C REP. SHELL
378 IF(ishfram==1)THEN
379 CALL write_i_c(0,1)
380 ELSE
381 CALL write_i_c(1,1)
382 ENDIF
383C
384 IF(isph3d==0.AND.
385 . (numsph_t+maxpjet/=0))THEN
386 CALL write_i_c(1,1)
387 ELSE
388 CALL write_i_c(0,1)
389 ENDIF
390C
391 CALL write_i_c(0,1)
392 CALL write_i_c(0,1)
393C
394 IF (nfvnod>0) THEN
395 nfvnodt=nfvnod+3
396 ELSE
397 nfvnodt=0
398 ENDIF
399C
400 CALL write_i_c(numnod+nodcut+nsect+nrwall+nnwl
401 . +nnsrg+nnsmd+nnsph+2*numels16+nfvnodt,1)
402 CALL write_i_c(nbf+nelcut+nesbw2+nfvtr,1)
403 nbpart2d=nbpart+ncuts+nsect+nrwall+nsurg+nsmad
404 CALL write_i_c(nbpart+ncuts
405 . +nsect+nrwall+nsurg+nsmad+nfvpart,1)
406 CALL write_i_c(nn_ani,1)
407 IF(nbf+nelcut+nesbw2+nfvtr==0)THEN
408 CALL write_i_c(0,1)
409 ELSE
410 IF (dsanim==1) THEN
411 nce_ani=nce_ani+nlevel
412 ELSEIF (decani==1) THEN
413 nce_ani=nce_ani+1
414 ENDIF
415 CALL write_i_c(nce_ani,1)
416 ENDIF
417 CALL write_i_c(nv_ani,1)
418 IF(nbf+nelcut+nesbw2+nfvtr==0)THEN
419 CALL write_i_c(0,1)
420 ELSE
421 CALL write_i_c(nct_ani,1)
422 ENDIF
423 CALL write_i_c(nskewa,1)
424C-----------------------------------------------
425C SKEW
426C-----------------------------------------------
427 bufl=1
428 CALL aniskew(elbuf_tab,skew ,iparg ,x ,ixt,
429 2 ixp ,ixr ,geo ,bufl )
430C-----------------------------------------------
431C NODE X Y Z
432C-----------------------------------------------
433 xmin = ep30
434 ymin = ep30
435 zmin = ep30
436 xmax = -ep30
437 ymax = -ep30
438 zmax = -ep30
439C
440 DO n=1,numnod
441 xmin = min(xmin,(x(1,n)-d(1,n)))
442 ymin = min(ymin,(x(2,n)-d(2,n)))
443 zmin = min(zmin,(x(3,n)-d(3,n)))
444 xmax = max(xmax,(x(1,n)-d(1,n)))
445 ymax = max(ymax,(x(2,n)-d(2,n)))
446 zmax = max(zmax,(x(3,n)-d(3,n)))
447 END DO
448C
449 cdg(1) = half * (xmax + xmin)
450 cdg(2) = half * (ymax + ymin)
451 cdg(3) = half * (zmax + zmin)
452C
453 DO i=1,numnod
454 r4 = x(1,i)
455 CALL write_r_c(r4,1)
456 r4 = x(2,i)
457 CALL write_r_c(r4,1)
458 r4 = x(3,i)
459 CALL write_r_c(r4,1)
460 END DO
461C
462 IF(nsect+nrwall>0) CALL dxyzsect(
463 2 nstrf,rwbuf,nprw ,x,xmin,
464 3 ymin,zmin,xmax,ymax,zmax,
465 4 itab)
466C
467 IF (nsurg>0) CALL dxyzsrg(nesrg,igrsurf,bufsf)
468C
469 snnsphg = 0
470 IF (isph3d*(numsph_t+maxpjet)>0)
471 . CALL dxyzsph(nesph,kxsp,x,spbuf,snnsphg,nnsph)
472C
473 sz16 = numels16
474 IF (sz16>0)
475 2 CALL xyz16(ixs,ixs10,ixs20,ixs16,x)
476C
477 IF (nfvnod>0) THEN
478 DO i=1,nfvbag
479 DO j=1,fvdata(i)%NNS_ANIM
480 r4=fvdata(i)%NOD_ANIM(1,j)
481 CALL write_r_c(r4,1)
482 r4=fvdata(i)%NOD_ANIM(2,j)
483 CALL write_r_c(r4,1)
484 r4=fvdata(i)%NOD_ANIM(3,j)
485 CALL write_r_c(r4,1)
486 ENDDO
487 ENDDO
488C
489 r4=em10
490 CALL write_r_c(r4,1)
491 r4=zero
492 CALL write_r_c(r4,1)
493 r4=zero
494 CALL write_r_c(r4,1)
495 r4=zero
496 CALL write_r_c(r4,1)
497 r4=em10
498 CALL write_r_c(r4,1)
499 r4=zero
500 CALL write_r_c(r4,1)
501 r4=zero
502 CALL write_r_c(r4,1)
503 r4=zero
504 CALL write_r_c(r4,1)
505 r4=em10
506 CALL write_r_c(r4,1)
507 nbid1=numnod+nodcut+nsect+nrwall+nnwl
508 . +nnsrg+nnsmd+nnsph+2*numels16+nfvnod+1
509 nbid2=nbid1+1
510 nbid3=nbid2+1
511C
512 ENDIF
513C-----------------------------------------------
514C PART SORT
515C-----------------------------------------------
516 CALL parsorc(x ,d, xnorm,iad ,cdg ,
517 . bufel,iparg,ixq ,ixc ,ixtg ,
518 . invert,el2fa,
519 . mater,ipartq,ipartc,iparttg,
520 . elbuf_tab)
521C
522 IF(nsect+nrwall>0) CALL dparrws(
523 1 nesbw2,nstrf, ixc ,
524 2 ixtg ,x ,nodcut,rwbuf,nprw,
525 3 ixs)
526C
527 IF (nsurg>0) CALL dparsrg(nsurg,nnwl,nodcut)
528C
529 ii=0
530 IF (ifvani==1) THEN
531 eloff=0
532 DO i=1,nfvbag
533 ALLOCATE(itagt(fvdata(i)%NNTR))
534 DO j=1,fvdata(i)%NNTR
535 itagt(j)=0
536 ENDDO
537C
538 DO j=1,fvdata(i)%NPOLH_ANIM
539 DO k=fvdata(i)%IFVPADR_ANIM(j),
540 . fvdata(i)%IFVPADR_ANIM(j+1)-1
541 kk=fvdata(i)%IFVPOLH_ANIM(k)
542 DO n=fvdata(i)%IFVTADR_ANIM(kk),
543 . fvdata(i)%IFVTADR_ANIM(kk+1)-1
544 nn=fvdata(i)%IFVPOLY_ANIM(n)
545 IF (itagt(nn)==1) cycle
546 inod(1)=fvoff(1,i)+fvdata(i)%IFVTRI_ANIM(1,nn)-1
547 inod(2)=fvoff(1,i)+fvdata(i)%IFVTRI_ANIM(2,nn)-1
548 inod(3)=fvoff(1,i)+fvdata(i)%IFVTRI_ANIM(3,nn)-1
549 inod(4)=inod(3)
550 ii=ii+1
551C Number of distinct nodes of the shell (after merging in FVMESH)
552 nnd=1
553 IF (inod(2)/=inod(1)) nnd=nnd+1
554 IF (inod(3)/=inod(1).AND.
555 . inod(3)/=inod(2)) nnd=nnd+1
556 IF (nnd/=3) THEN
557 inod(1)=nbid1-1
558 inod(2)=nbid2-1
559 inod(3)=nbid3-1
560 inod(4)=inod(3)
561 ENDIF
562C
563 CALL write_i_c(inod,4)
564 itagt(nn)=1
565 fvel2fa(eloff+nn)=ii
566 fvinum(ii)=eloff+nn
567 ENDDO
568 ENDDO
569 ENDDO
570 eloff=eloff+fvdata(i)%NNTR
571 DEALLOCATE(itagt)
572 ENDDO
573 ENDIF
574C-----------------------------------------------
575C OFF
576C-----------------------------------------------
577 CALL anioffc(elbuf_tab,iparg,waft ,el2fa,nbf )
578C
579 DO j=1,nesbw2+nelcut
580 CALL write_c_c(1,1)
581 ENDDO
582C
583 IF (ifvani==1) THEN
584 ALLOCATE(offtr(nfvtr))
585 DO i=1,nfvtr
586 offtr(i)=0
587 ENDDO
588 eloff=0
589 DO i=1,nfvbag
590 DO j=1,fvdata(i)%NPOLH
591 DO k=fvdata(i)%IFVPADR(j),fvdata(i)%IFVPADR(j+1)-1
592 kk=fvdata(i)%IFVPOLH(k)
593 DO n=fvdata(i)%IFVTADR(kk),
594 . fvdata(i)%IFVTADR(kk+1)-1
595 nn=fvdata(i)%IFVPOLY(n)
596 IF (nn>0) THEN
597 n1=fvdata(i)%IFVTRI_ANIM(1,nn)
598 n2=fvdata(i)%IFVTRI_ANIM(2,nn)
599 n3=fvdata(i)%IFVTRI_ANIM(3,nn)
600 nnd=1
601 IF (n2/=n1) nnd=nnd+1
602 IF (n3/=n2.AND.n3/=n1) nnd=nnd+1
603C
604 nn=fvel2fa(eloff+nn)
605 IF (nnd==3) offtr(nn)=1
606 ENDIF
607 ENDDO
608 ENDDO
609 ENDDO
610 eloff=eloff+fvdata(i)%NNTR
611 ENDDO
612C
613 CALL write_c_c(offtr,nfvtr)
614 DEALLOCATE(offtr)
615 ENDIF
616C-----------------------------------------------
617C PART ADD
618C-----------------------------------------------
619 CALL write_i_c(iad,nbpart)
620 nesct1=0
621 DO isect=1,nsect
622 CALL donesec(isect,nesct1,nstrf,ixs)
623 CALL write_i_c(nelcut+nbf+nesct1,1)
624 END DO
625C
626 nerwl1=0
627 DO irwl=1,nrwall
628 CALL donerwl(irwl,nerwl1,nprw)
629 CALL write_i_c(nelcut+nbf+nesct+nerwl1,1)
630 END DO
631 nesrg1=0
632C
633 DO isrg=1,nsurg
634 CALL donesrg(isrg,nesrg1)
635 CALL write_i_c(nelcut+nbf+nesct+nerwl+nesrg1,1)
636 END DO
637 nesmd1=0
638C
639 IF (ifvani==1) THEN
640 fviad=nelcut+nbf+nesct+nerwl+nesrg+nesmd1
641 DO i=1,nfvbag
642 ALLOCATE(itagt(fvdata(i)%NNTR))
643 DO j=1,fvdata(i)%NNTR
644 itagt(j)=0
645 ENDDO
646C
647 DO j=1,fvdata(i)%NPOLH_ANIM
648 DO k=fvdata(i)%IFVPADR_ANIM(j),
649 . fvdata(i)%IFVPADR_ANIM(j+1)-1
650 kk=fvdata(i)%IFVPOLH_ANIM(k)
651 DO n=fvdata(i)%IFVTADR_ANIM(kk),
652 . fvdata(i)%IFVTADR_ANIM(kk+1)-1
653 nn=fvdata(i)%IFVPOLY_ANIM(n)
654 IF (itagt(nn)==0) THEN
655 fviad=fviad+1
656 itagt(nn)=1
657 ENDIF
658 ENDDO
659 ENDDO
660 CALL write_i_c(fviad,1)
661 ENDDO
662C
663 DEALLOCATE(itagt)
664 ENDDO
665 ENDIF
666C-----------------------------------------------
667C PART HEAD
668C-----------------------------------------------
669 idpart2dmax=0
670 DO i=1,npart
671 IF(mater(i)/=0)THEN
672 idpart2dmax=max(idpart2dmax,ipart(4,i))
673 WRITE(str,'(I8,A1)')ipart(4,i),':'
674 DO j=1,9
675 ctext(j)=ichar(str(j:j))
676 ENDDO
677 ib = 9
678 CALL fretitl2(titl,ipart(lipart1-ltitr+1,i),ltitl)
679 DO j=1,ltitl
680 IF(titl(j:j)/=' ') ib = j+9
681 ctext(j+9)=ichar(titl(j:j))
682 ENDDO
683 ctext(ib+1)=0
684 CALL write_c_c(ctext,10+ltitl)
685 ENDIF
686 ENDDO
687C-----------------------------------------------
688C CUTS PART
689C-----------------------------------------------
690c print*,'685(664)-870'
691c return
692 IF (invstr<40) THEN
693 DO isect=1,nsect
694 WRITE(str,'(I8,A2,A7)') isect,': ','Section'
695 DO j=1,17
696 ctext(j)=ichar(str(j:j))
697 ENDDO
698 ib = 17
699 ctext(ib+1)=0
700 CALL write_c_c(ctext,10+ltitl)
701 END DO
702 ELSE
703 DO isect=1,nsect
704 WRITE(str,'(I8,A2)') nom_opt(1,ptr_nopt_sect+isect),': '
705 DO j=1,10
706 ctext(j)=ichar(str(j:j))
707 ENDDO
708 CALL fretitl2(titl,nom_opt(lnopt1-ltitr+1,ptr_nopt_sect+isect),
709 . ltitl)
710 ib = ltitl+9
711 DO j=1,ltitl
712 ctext(j+10)=ichar(titl(j:j))
713 ENDDO
714 ctext(ib+1)=0
715 CALL write_c_c(ctext,10+ltitl)
716 END DO
717 END IF
718C
719 IF (invstr<40) THEN
720 DO irwl=1,nrwall
721 WRITE(str,'(I8,A2,A10)') irwl,': ','Rigid Wall'
722 DO j=1,20
723 ctext(j)=ichar(str(j:j))
724 ENDDO
725 ib = 20
726 ctext(ib+1)=0
727 CALL write_c_c(ctext,10+ltitl)
728 END DO
729 ELSE
730 DO irwl=1,nrwall
731 WRITE(str,'(I8,A2)') nom_opt(1,ptr_nopt_rwall+irwl),': '
732 DO j=1,10
733 ctext(j)=ichar(str(j:j))
734 ENDDO
735 ib = ltitl+9
736 CALL fretitl2(titl,nom_opt(lnopt1-ltitr+1,ptr_nopt_rwall+irwl),
737 . ltitl)
738 DO j=1,ltitl
739 ctext(j+10)=ichar(titl(j:j))
740 END DO
741 ctext(ib+1)=0
742 CALL write_c_c(ctext,10+ltitl)
743 END DO
744 ENDIF
745C
746 isrg=1
747 DO isrf=1,nsurf
748 IF (igrsurf(isrf)%TYPE==101) THEN
749C RADIOSS'S ellipsoid.
750 WRITE(str,'(I8,A1)') isrg,':'
751 DO j=1,9
752 ctext(j)=ichar(str(j:j))
753 ENDDO
754 ib=9
755 titl = igrsurf(isrf)%TITLE
756 DO j=1,ltitl
757 IF(titl(j:j)/=' ') ib = j+9
758 ctext(j+9)=ichar(titl(j:j))
759 END DO
760 ctext(ib+1)=0
761 CALL write_c_c(ctext,10+ltitl)
762 isrg=isrg+1
763 END IF
764 END DO
765 idpart2dmax = idpart2dmax + nsect + nrwall + nsurg + nsmad + ncuts
766C-------------------------------------------------------
767C FVMBAG
768C-------------------------------------------------------
769 IF (ifvani==1) THEN
770 DO i=1,nfvbag
771 DO j=1,fvdata(i)%NPOLH_ANIM
772 WRITE(str,'(I8,A1)') j+idpart2dmax,':'
773 DO k=1,9
774 ctext(k)=ichar(str(k:k))
775 ENDDO
776 titl=' '
777 WRITE(titl,'(A11,I8)') 'POLYHEDRON ',j
778 DO k=1,ltitl
779 ctext(k+9)=ichar(titl(k:k))
780 ENDDO
781 ctext(29)=0
782 CALL write_c_c(ctext,10+ltitl)
783 ENDDO
784 idpart2dmax = idpart2dmax + fvdata(i)%NPOLH_ANIM
785 ENDDO
786 ENDIF
787C-----------------------------------------------
788C NORMAL
789C-----------------------------------------------
790 CALL xyznor(xnorm)
791C
792 CALL dsecnor(x ,rwbuf,nprw)
793 IF (nsurg>0) CALL dsrgnor(igrsurf,bufsf)
794 snnsphg = 0
795 IF (isph3d*(numsph_t+maxpjet)>0)
796 . CALL dsphnor(kxsp,x,spbuf,nnsphg)
797 IF (numels16>0)
798 . CALL xyznor16(ixs,ixs10,ixs20,ixs16,x)
799C
800 IF (ifvani==1) THEN
801 DO i=1,nfvnod
802 inorm(1) = 0
803 inorm(2) = 0
804 inorm(3) = 0
805 CALL write_s_c(inorm,3)
806 ENDDO
807 IF (nfvnod>0) THEN
808 DO i=1,3
809 inorm(1) = 0
810 inorm(2) = 0
811 inorm(3) = 0
812 CALL write_s_c(inorm,3)
813 ENDDO
814 ENDIF
815 ENDIF
816C-----------------------------------------------
817C ELEMENT MASS FOR MAS & FUNC
818C-----------------------------------------------
819 IF(anim_m==1.OR.anim_ce(3)==1.OR.
820 . anim_ce(25)==1)THEN
821 CALL dmasanic(elbuf_tab, x ,d ,geo ,iparg,
822 . ixq ,ixc ,ixtg ,mas ,pm ,
823 . el2fa,nbf )
824 ENDIF
825C-----------------------------------------------
826C E(quad+shell+truss+..) FUNC TEXT
827C-----------------------------------------------
828 IF(nbf+nelcut+nesbw2/=0)THEN
829 DO i=1,nmanim
830 WRITE(ctmod,'(A7,I4,A8,I4,A18)')
831 . 'Fxbody ',fxani(1,i),' - Mode ',fxani(2,i),' - Specific Energy'
832 CALL ani_txt(ctmod,41)
833 WRITE(ctmod,'(A7,I4,A8,I4,A11)')
834 . 'Fxbody ',fxani(1,i),' - Mode ',fxani(2,i),' - Pressure'
835 CALL ani_txt(ctmod,34)
836 WRITE(ctmod,'(A7,I4,A8,I4,A12)')
837 . 'Fxbody ',fxani(1,i),' - Mode ',fxani(2,i),' - Von Mises'
838 CALL ani_txt(ctmod,35)
839 WRITE(ctmod,'(A7,I4,A8,I4,A12)')
840 . 'Fxbody ',fxani(1,i),' - Mode ',fxani(2,i),' - Stress X '
841 CALL ani_txt(ctmod,35)
842 WRITE(ctmod,'(A7,I4,A8,I4,A12)')
843 . 'Fxbody ',fxani(1,i),' - Mode ',fxani(2,i),' - Stress Y '
844 CALL ani_txt(ctmod,35)
845 WRITE(ctmod,'(A7,I4,A8,I4,A12)')
846 . 'Fxbody ',fxani(1,i),' - Mode ',fxani(2,i),' - Stress Z '
847 CALL ani_txt(ctmod,35)
848 WRITE(ctmod,'(A7,I4,A8,I4,A12)')
849 . 'Fxbody ',fxani(1,i),' - Mode ',fxani(2,i),' - Stress XY'
850 CALL ani_txt(ctmod,35)
851 WRITE(ctmod,'(A7,I4,A8,I4,A12)')
852 . 'Fxbody ',fxani(1,i),' - Mode ',fxani(2,i),' - Stress YZ'
853 CALL ani_txt(ctmod,35)
854 WRITE(ctmod,'(A7,I4,A8,I4,A12)')
855 . 'Fxbody ',fxani(1,i),' - Mode ',fxani(2,i),' - Stress XZ'
856 CALL ani_txt(ctmod,35)
857 ENDDO
858 IF (dsanim==1) THEN
859 DO i=1,nlevel
860 CALL ani_txt(ctitr(i),33)
861 ENDDO
862 ELSEIF (decani==1) THEN
863 CALL ani_txt(ctitr(1),25)
864 ENDIF
865 ENDIF
866C-----------------------------------------------
867C ELEMENT FUNC (quad+coque)
868C-----------------------------------------------
869 ndma2= numnod*(min(1,anim_n(1)+outp_n(1))
870 . +min(1,anim_n(2)+outp_n(2))
871 . +min(1,anim_n(12)+outp_n(3)))
872 IF((nbf+nelcut+nesbw2/=0)) THEN
873 DO i = 1,mx_ani
874 ifunc = i
875 IF(anim_ce(i)==1) THEN
876
877 CALL dfuncc(elbuf_tab,bufel,waft ,ifunc,iparg,
878 . ixq ,ixc ,ixtg ,pm ,el2fa,
879 . nbf )
880 r4 = zero
881 DO j=1,nesbw2
882 CALL write_r_c(r4,1)
883 ENDDO
884C
885 IF (nfvtr>0) THEN
886 r4=zero
887 DO j=1,nfvtr
888 CALL write_r_c(r4,1)
889 ENDDO
890 ENDIF
891C
892 ENDIF
893 ENDDO
894C
895 nmfunc(1)=3
896 nmfunc(2)=6
897 nmfunc(3)=7
898 nmfunc(4)=14
899 nmfunc(5)=15
900 nmfunc(6)=16
901 nmfunc(7)=17
902 nmfunc(8)=18
903 nmfunc(9)=19
904 DO i=1,nmanim ! Don't work !!!
905 DO j=1,9
906 ifunc=nmfunc(j)
907 CALL dfuncc(elbuf_tab,mbufel(1,i), waft, ifunc, iparg,
908 . ixq, ixc, ixtg, pm,
909 . el2fa, nbf)
910 r4 = zero
911 DO k=1,nesbw2
912 CALL write_r_c(r4,1)
913 ENDDO
914 IF (nfvtr>0) THEN
915 r4=zero
916 DO k=1,nfvtr
917 CALL write_r_c(r4,1)
918 ENDDO
919 ENDIF
920 ENDDO
921 ENDDO
922c
923 IF (dsanim==1) THEN
924 DO i=1,nlevel
925 DO j=1,nbf
926 func(j)=zero
927 ENDDO
928C Quad + Shell
929 off=1+numels
930 CALL delsub(nlevel, elsub, i, off, numelq+numelc,
931 . el2fa , func)
932C Shell 3 nodes
933 off=off+numelq+numelc+numelt+numelp+numelr
934 CALL delsub(nlevel, elsub, i, off, numeltg,
935 . el2fa(1+numelq+numelc), func)
936C
937 DO j=1,nbf
938 r4=func(j)
939 CALL write_r_c(r4,1)
940 ENDDO
941 r4=zero
942 DO j=1,nesbw2
943 CALL write_r_c(r4,1)
944 ENDDO
945 IF (nfvtr>0) THEN
946 r4=zero
947 DO j=1,nfvtr
948 CALL write_r_c(r4,1)
949 ENDDO
950 ENDIF
951 ENDDO
952 ELSEIF (decani==1) THEN
953 DO i=1,nbf
954 func(i)=zero
955 ENDDO
956C Quad + Shell
957 off=1+numels
958 CALL delsub(1, cep, 1, off, numelq+numelc,
959 . el2fa, func)
960C Shell 3 nodes
961 off=off+numelq+numelc+numelt+numelp+numelr
962 CALL delsub(1, cep, 1, off, numeltg,
963 . el2fa(1+numelq+numelc), func)
964C
965 DO i=1,nbf
966 r4=func(i)
967 CALL write_r_c(r4,1)
968 ENDDO
969 r4=zero
970 DO i=1,nesbw2
971 CALL write_r_c(r4,1)
972 ENDDO
973 IF (nfvtr>0) THEN
974 r4=zero
975 DO j=1,nfvtr
976 CALL write_r_c(r4,1)
977 ENDDO
978 ENDIF
979 ENDIF
980 ENDIF
981C-----------------------------------------------
982C VECT TEXT
983C-----------------------------------------------
984 DO i=1,nmanim
985 WRITE(ctmod,'(A7,I4,A8,I4,A15)')
986 . 'Fxbody ',fxani(1,i),' - Mode ',fxani(2,i),' - Displacement'
987 CALL ani_txt(ctmod,38)
988 ENDDO
989C
990 nnnsrg=nnsrg+nnsmd+nnsph+2*numels16
991 DO i=1,nmanim
992 CALL velvec(mdepl(1,i),nnwl,nnnsrg)
993 ENDDO
994C-----------------------------------------------
995C 2D TENSOR TEXT
996C-----------------------------------------------
997 IF((nbf+nelcut+nesbw2/=0))THEN
998 DO i=1,nmanim
999 WRITE(ctmod,'(A7,I4,A8,I4,A21)')
1000 . 'Fxbody ',fxani(1,i),' - Mode ',fxani(2,i),
1001 . ' - Stress (membrane)'
1002 CALL ani_txt(ctmod,44)
1003 WRITE(ctmod,'(A7,I4,A8,I4,A23)')
1004 . 'Fxbody ',fxani(1,i),' - Mode ',fxani(2,i),
1005 . ' - Stress (moment/t^2)'
1006 CALL ani_txt(ctmod,46)
1007 ENDDO
1008C-----------------------------------------------
1009C 2D TENSOR
1010C-----------------------------------------------
1011 DO i = 1,mx_ani
1012 ifunc = i
1013 IF(anim_ct(i)==1)THEN
1014 CALL tensorc(elbuf_tab ,iparg,ifunc,
1015 . invert,nelcut,el2fa,nbf ,waft ,
1016 . iad,nbf_l,nbpart,
1017 . x, ixc, igeo,ixtg )
1018 r4 = zero
1019 DO j=1,nesbw2
1020 CALL write_r_c(r4,1)
1021 CALL write_r_c(r4,1)
1022 CALL write_r_c(r4,1)
1023 ENDDO
1024 ENDIF
1025 ENDDO
1026 nmfunc(1)=1
1027 nmfunc(2)=2
1028 DO i=1,nmanim ! Don't work !!!
1029 DO j=1,2
1030 ifunc=nmfunc(j)
1031! CALL TENSORC(MBUFEL(1,I), IPARG, IFUNC,
1032! . INVERT, NELCUT, EL2FA, NBF, WAFT,
1033! .IAD, nbf_l, nbpart,
1034! . X, IXC, IGEO, IXTG)
1035 r4 = zero
1036 DO k=1,nesbw2
1037 CALL write_r_c(r4,1)
1038 CALL write_r_c(r4,1)
1039 CALL write_r_c(r4,1)
1040 ENDDO
1041 ENDDO
1042 ENDDO
1043 ENDIF
1044C-----------------------------------------------
1045C ELEMENT MASS
1046C-----------------------------------------------
1047 IF(anim_m==1)THEN
1048 DO i=1,nbf
1049 r4 = mas(i)
1050 CALL write_r_c(r4,1)
1051 ENDDO
1052C
1053 r4 = 0.
1054 DO j=1,nesbw2+nelcut
1055 CALL write_r_c(r4,1)
1056 ENDDO
1057 IF (nfvtr>0) THEN
1058 r4=zero
1059 DO j=1,nfvtr
1060 CALL write_r_c(r4,1)
1061 ENDDO
1062 ENDIF
1063C-----------------------------------------------
1064C NODAL MASS (FLUX FOR CUT)
1065C-----------------------------------------------
1066 DO i=1,numnod
1067 wa4(i)=ms(i)
1068 ENDDO
1069
1070 DO n=1,nrbykin
1071 m=npby(1,n)
1072 IF (m>0) THEN
1073 wa4(m)=wa4(m)+(rby(15,n)-ms(m))
1074 ENDIF
1075 ENDDO
1076
1077 DO k=1,numnod
1078 r4 = wa4(n)
1079 CALL write_r_c(r4,1)
1080 ENDDO
1081C
1082 r4 = zero
1083 sz16 = numels16
1084 sznnsph = nnsph
1085 DO n=1,nsect+nrwall+nnwl+nnsrg+nnsmd+sznnsph+2*sz16
1086 CALL write_r_c(r4,1)
1087 ENDDO
1088 IF (nfvnod>0) THEN
1089 r4=zero
1090 DO n=1,nfvnod+3
1091 CALL write_r_c(r4,1)
1092 ENDDO
1093 ENDIF
1094 ENDIF
1095C-------------------
1096C NODAL NUMBERING
1097C-------------------
1098 CALL write_i_c(itab,numnod)
1099 sz16 = numels16
1100 sznnsph = nnsph
1101 DO i=1,nodcut+nsect+nrwall+nnwl+nnsrg+nnsmd+sznnsph+2*sz16
1102 CALL write_i_c(0,1)
1103 ENDDO
1104C
1105 IF (nfvnod>0) THEN
1106 DO i=1,nfvbag
1107 IF (fvdata(i)%NPOLH_ANIM>0) THEN
1108 DO j=1,fvdata(i)%NNS_ANIM
1109 jj=fvoff(2,i)+j
1110 CALL write_i_c(jj,1)
1111 ENDDO
1112 ENDIF
1113 ENDDO
1114 CALL write_i_c(idmax+nfvnod+1,1)
1115 CALL write_i_c(idmax+nfvnod+2,1)
1116 CALL write_i_c(idmax+nfvnod+3,1)
1117 ENDIF
1118C--------------------
1119C ELEMENT NUMBERING
1120C--------------------
1121 CALL delnumbc(iparg,ixq ,ixc ,ixtg ,
1122 . el2fa,nbf ,waft ,nelcut,
1123 . nbpart,idcmax)
1124 DO j=1,nesbw2
1125 CALL write_i_c(0,1)
1126 ENDDO
1127 IF (nfvtr>0) THEN
1128 DO i=1,nfvtr
1129 CALL write_i_c(idcmax+fvinum(i),1)
1130 ENDDO
1131 DEALLOCATE(fvel2fa, fvinum)
1132 ENDIF
1133C-----------------------------------------------
1134C HIERARCHY
1135C-----------------------------------------------
1136C Transmis a ANIM ::
1137C Subset Rbodies == NSUBS
1138C Subset Sections == NSUBS+MIN(1,NRBODY)
1139C Subset Rwalls == NSUBS+MIN(1,NSECT)+MIN(1,NRBODY)
1140C Subset Surfaces == NSUBS+MIN(1,NSECT)+MIN(1,NRBODY)+MIN(1,NRWAL
1141C Subset global == NSUBS+MIN(1,NSECT)+MIN(1,NRBODY)+MIN(1,NRWAL
1142C +MIN(1,NSURG+NSMAD)
1143 DO i=1,npart
1144 IF(mater(i)==1) THEN
1145 IF (ipart(3,i)<nsubs) THEN
1146 CALL write_i_c(ipart(3,i)-1,1)
1147 ELSE
1148 CALL write_i_c(nsubs
1149 . +min(1,nsect)+min(1,nrbody)+min(1,nrwall)
1150 . +min(1,nsurg+nsmad)+nfvsubs-1,1)
1151 END IF
1152 END IF
1153 ENDDO
1154 DO i=1,ncuts
1155 CALL write_i_c(nsubs
1156 . +min(1,nsect)+min(1,nrbody)+min(1,nrwall)
1157 . +min(1,nsurg+nsmad)-1,1)
1158 ENDDO
1159 DO i=1,nsect
1160 CALL write_i_c(nsubs+min(1,nrbody)-1,1)
1161 END DO
1162 DO i=1,nrwall
1163 CALL write_i_c(nsubs+min(1,nsect)+min(1,nrbody)-1,1)
1164 END DO
1165 DO i=1,nsurg
1166 CALL write_i_c(nsubs+min(1,nsect)+min(1,nrbody)
1167 . +min(1,nrwall)-1,1)
1168 END DO
1169 DO i=1,nsmad
1170 CALL write_i_c(nsubs+min(1,nsect)+min(1,nrbody)
1171 . +min(1,nrwall)-1,1)
1172 END DO
1173 IF (nfvtr>0) THEN
1174 ii=nsubs
1175 . +min(1,nsect)+min(1,nrbody)+min(1,nrwall)
1176 . +min(1,nsurg+nsmad)-1
1177 DO i=1,nfvbag
1178 IF (fvdata(i)%NPOLH_ANIM>0) THEN
1179 ii=ii+1
1180 DO j=1,fvdata(i)%NPOLH_ANIM
1181 CALL write_i_c(ii-1,1)
1182 ENDDO
1183 ENDIF
1184 ENDDO
1185 ENDIF
1186C
1187 DO i=1,npart
1188 IF(mater(i)==1)CALL write_i_c(ipart(1,i),1)
1189 ENDDO
1190 DO i=1,ncuts+nrwall+nsect+nsurg+nsmad
1191 CALL write_i_c(0,1)
1192 ENDDO
1193 DO i=1,nfvpart
1194 CALL write_i_c(0,1)
1195 ENDDO
1196C
1197 DO i=1,npart
1198 IF(mater(i)==1)CALL write_i_c(ipart(2,i),1)
1199 ENDDO
1200 DO i=1,ncuts+nrwall+nsect+nsurg+nsmad
1201 CALL write_i_c(0,1)
1202 ENDDO
1203 DO i=1,nfvpart
1204 CALL write_i_c(0,1)
1205 ENDDO
1206C=======================================================================
1207C
1208C BRICKS
1209C
1210C=======================================================================
1211 IF (numels_t+numels16_t+isph3d*(numsph_t+maxpjet)>=0.OR.
1212 . (isph3d==1.AND.numsph_t+maxpjet>0)) THEN
1213 IF (dsanim==1) THEN
1214 nse_ani=nse_ani+nlevel
1215 ELSEIF (decani==1) THEN
1216 nse_ani=nse_ani+1
1217 ENDIF
1218 ENDIF
1219 IF(numels_t+numels16_t+isph3d*(numsph_t+maxpjet)==0)GOTO 400
1220C-----------------------------------------------
1221C PART COUNT
1222C-----------------------------------------------
1223C
1224 DO i=1,numels
1225 mater(iparts(i))=2
1226 el2fa(i)=0
1227 ENDDO
1228
1229 DO i=1,3*numels16
1230 el2fa(numels+i)=0
1231 ENDDO
1232
1233C 3D geometry is not yet treated.
1234
1235 IF(isph3d/=0)THEN
1236 DO i=1,numsph+maxpjet
1237 mater(ipartsp(i))=2
1238 el2fa(numels+3*numels16+i)=0
1239 ENDDO
1240 ENDIF
1241C
1242 nbpart = 0
1243 DO i=1,npart
1244 nbpart = nbpart + mater(i)/2
1245 ENDDO
1246C-----------------------------------------------
1247C WRITE CONTROL
1248C-----------------------------------------------
1249 CALL write_i_c(numels+isph3d*(numsph+maxpjet)
1250 . +3*numels16,1)
1251 CALL write_i_c(nbpart,1)
1252 CALL write_i_c(nse_ani,1)
1253 CALL write_i_c(nst_ani,1)
1254C-----------------------------------------------
1255C PART SORT
1256C-----------------------------------------------
1257 shftsph = numnod+nodcut+nsect+nrwall+nnwl+nnsrg+nnsmd
1258 shft16 = numnod+nodcut+nsect+nrwall+nnwl+nnsrg+nnsmd+nnsphg
1259 insph=numnod+nodcut+nsect+nrwall+nnwl
1260 . +nnsrg+nnsmd
1261 CALL parsors(iad ,iparg ,ixs ,mater,iparts,
1262 2 el2fa ,
1263 3 insph ,kxsp ,ipartsp,
1264 4 ixs10 ,ixs20 ,ixs16 ,nnsph ,isph3d,
1265 5 shft16 ,shftsph,nnsphg )
1266C-----------------------------------------------
1267C OFF
1268C-----------------------------------------------
1269 nnn = numels+isph3d*(numsph+maxpjet)+3*numels16
1270 CALL anioffs(elbuf_tab ,iparg,waft ,el2fa ,
1271 . nnn ,nbpart,isph3d )
1272C-----------------------------------------------
1273C PART ADD
1274C-----------------------------------------------
1275 CALL write_i_c(iad,nbpart)
1276C-----------------------------------------------
1277C PART HEAD
1278C-----------------------------------------------
1279 DO i=1,npart
1280 IF(mater(i)==2)THEN
1281 WRITE(str,'(I8,A1)')ipart(4,i),':'
1282 DO j=1,9
1283 ctext(j)=ichar(str(j:j))
1284 ENDDO
1285 ib = 9
1286 CALL fretitl2(titl,ipart(lipart1-ltitr+1,i),ltitl)
1287 DO j=1,ltitl
1288 IF(titl(j:j)/=' ') ib = j+9
1289 ctext(j+9)=ichar(titl(j:j))
1290 END DO
1291 ctext(ib+1)=0
1292 CALL write_c_c(ctext,10+ltitl)
1293 ENDIF
1294 ENDDO
1295C-----------------------------------------------
1296C ELEMENT MASS FOR MAS & FUNC
1297C-----------------------------------------------
1298 IF(anim_m==1.OR.anim_se(3)==1.OR.
1299 . anim_se(25)==1)THEN
1300 CALL dmasanis(elbuf_tab,iparg ,
1301 2 ixs ,mas ,pm ,el2fa ,numels ,
1302 3 ipart ,ipartsp ,isph3d )
1303 ENDIF
1304C-----------------------------------------------
1305C BRICK FUNC TEXT
1306C-----------------------------------------------
1307 ctext(81)=0
1308 DO i=1,nmanim
1309 WRITE(ctmod,'(A7,I4,A8,I4,A18)')
1310 . 'Fxbody ',fxani(1,i),' - Mode ',fxani(2,i),' - Specific Energy'
1311 CALL ani_txt(ctmod,41)
1312 WRITE(ctmod,'(A7,I4,A8,I4,A11)')
1313 . 'Fxbody ',fxani(1,i),' - Mode ',fxani(2,i),' - Pressure'
1314 CALL ani_txt(ctmod,34)
1315 WRITE(ctmod,'(A7,I4,A8,I4,A12)')
1316 . 'Fxbody ',fxani(1,i),' - Mode ',fxani(2,i),' - Von Mises'
1317 CALL ani_txt(ctmod,35)
1318 WRITE(ctmod,'(A7,I4,A8,I4,A12)')
1319 . 'Fxbody ',fxani(1,i),' - Mode ',fxani(2,i),' - Stress X '
1320 CALL ani_txt(ctmod,35)
1321 WRITE(ctmod,'(A7,I4,A8,I4,A12)')
1322 . 'Fxbody ',fxani(1,i),' - Mode ',fxani(2,i),' - Stress Y '
1323 CALL ani_txt(ctmod,35)
1324 WRITE(ctmod,'(A7,I4,A8,I4,A12)')
1325 . 'Fxbody ',fxani(1,i),' - Mode ',fxani(2,i),' - Stress Z '
1326 CALL ani_txt(ctmod,35)
1327 WRITE(ctmod,'(A7,I4,A8,I4,A12)')
1328 . 'Fxbody ',fxani(1,i),' - Mode ',fxani(2,i),' - Stress XY'
1329 CALL ani_txt(ctmod,35)
1330 WRITE(ctmod,'(a7,i4,a8,i4,a12)')
1331 . 'fxbody ',FXANI(1,I),' - mode ',FXANI(2,I),' - stress yz'
1332 CALL ANI_TXT(CTMOD,35)
1333 WRITE(CTMOD,'(a7,i4,a8,i4,a12)')
1334 . 'fxbody ',FXANI(1,I),' - mode ',FXANI(2,I),' - stress xz'
1335 CALL ANI_TXT(CTMOD,35)
1336 ENDDO
1337 IF (DSANIM==1) THEN
1338 DO I=1,NLEVEL
1339 CALL ANI_TXT(CTITR(I),33)
1340 ENDDO
1341 ELSEIF (DECANI==1) THEN
1342 CALL ANI_TXT(CTITR(1),25)
1343 ENDIF
1344C-----------------------------------------------
1345C ELEMENT FUNC (brick)
1346C-----------------------------------------------
1347 NDMA2= NUMNOD*(MIN(1,ANIM_N(1)+OUTP_N(1))
1348 . +MIN(1,ANIM_N(2)+OUTP_N(2))
1349 . +MIN(1,ANIM_N(12)+OUTP_N(3)))
1350 NNN = NUMELS+ISPH3D*(NUMSPH+MAXPJET)+3*NUMELS16
1351 DO I = 1,MX_ANI
1352 IFUNC = I
1353 IF(ANIM_SE(I)==1) THEN
1354 CALL DFUNCS(ELBUF_TAB ,WAFT ,IFUNC ,IPARG ,
1355 2 IXS ,PM ,EL2FA ,NNN ,ISPH3D )
1356 ENDIF
1357 ENDDO
1358C
1359 NMFUNC(1)=3
1360 NMFUNC(2)=6
1361 NMFUNC(3)=7
1362 NMFUNC(4)=14
1363 NMFUNC(5)=15
1364 NMFUNC(6)=16
1365 NMFUNC(7)=17
1366 NMFUNC(8)=18
1367 NMFUNC(9)=19
1368 DO I=1,NMANIM ! Don't work !!!
1369 DO j=1,9
1370 ifunc=nmfunc(j)
1371 CALL dfuncs(mbufel(1,i), waft, ifunc, iparg,
1372 . ixs,pm ,el2fa, nnn,isph3d)
1373 ENDDO
1374 ENDDO
1375 IF (dsanim==1) THEN
1376 DO i=1,nlevel
1377 DO j=1,nnn
1378 func(j)=zero
1379 ENDDO
1380C Brick
1381 off=1
1382 CALL delsub(nlevel, elsub, i, off, numels,
1383 . el2fa, func)
1384C
1385 DO j=1,nnn
1386 r4=func(j)
1387 CALL write_r_c(r4,1)
1388 ENDDO
1389 ENDDO
1390 ELSEIF (decani==1) THEN
1391 DO i=1,nnn
1392 func(i)=zero
1393 ENDDO
1394C Brick
1395 off=1
1396 CALL delsub(1, cep, 1, off, numels,
1397 . el2fa, func)
1398C SPH particles
1399 IF (isph3d==1) THEN
1400 off=1
1401 CALL delsub(1, cepsp,1 ,off, numsph,
1402 . el2fa(1+numels), func)
1403 ENDIF
1404C
1405 DO i=1,nnn
1406 r4=func(i)
1407 CALL write_r_c(r4,1)
1408 ENDDO
1409 ENDIF
1410C-----------------------------------------------
1411C 3D TENSOR TEXT
1412C-----------------------------------------------
1413 DO i=1,nmanim
1414 WRITE(ctmod,'(A7,I4,A8,I4,A9)')
1415 . 'Fxbody ',fxani(1,i),' - Mode ',fxani(2,i),' - Stress'
1416 CALL ani_txt(ctmod,32)
1417 ENDDO
1418C-----------------------------------------------
1419C 3D TENSOR
1420C-----------------------------------------------
1421 DO i = 1,mx_ani
1422 ifunc = i
1423 IF(anim_st(i)==1)THEN
1424 CALL tensors(elbuf_tab ,iparg ,ifunc ,ixs ,pm ,
1425 2 el2fa ,nnn ,waft ,
1426 3 x ,ipart ,ipartsp ,isph3d ,ipm )
1427 ENDIF
1428 ENDDO
1429 nmfunc(1)=1
1430 DO i=1,nmanim
1431 DO j=1,1
1432 ifunc=nmfunc(j)
1433! CALL TENSORS(MBUFEL(1,I), IPARG, IFUNC, IXS, PM,
1434! . EL2FA, NNN, WAFT,
1435! . X, IPART,IPARTSP, ISPH3D, IPM )
1436 ENDDO
1437 ENDDO
1438C-----------------------------------------------
1439C ELEMENT MASS
1440C-----------------------------------------------
1441 IF(anim_m==1)THEN
1442 DO i=1,nnn
1443 r4 = mas(i)
1444 CALL write_r_c(r4,1)
1445 ENDDO
1446 ENDIF
1447C-----------------------------------------------
1448C BRICK NUMBERING
1449C-----------------------------------------------
1450 CALL delnumbs(iparg,ixs ,el2fa,nnn ,waft ,
1451 . kxsp ,isph3d )
1452C-----------------------------------------------
1453C HIERARCHY
1454C-----------------------------------------------
1455 DO i=1,npart
1456 IF(mater(i)==2)THEN
1457 IF (ipart(3,i)<nsubs) THEN
1458 CALL write_i_c(ipart(3,i)-1,1)
1459 ELSE
1460 CALL write_i_c(nsubs
1461 . +min(1,nsect)+min(1,nrbody)+min(1,nrwall)
1462 . +min(1,nsurg+nsmad)-1,1)
1463 END IF
1464 END IF
1465 ENDDO
1466 DO i=1,npart
1467 IF(mater(i)==2)CALL write_i_c(ipart(1,i),1)
1468 ENDDO
1469 DO i=1,npart
1470 IF(mater(i)==2)CALL write_i_c(ipart(2,i),1)
1471 ENDDO
1472C=======================================================================
1473 400 CONTINUE
1474C=======================================================================
1475C
1476C POUTRE TRUSS SPRING
1477C + RBODIES
1478C
1479C=======================================================================
1480 nerby = 0
1481 IF (nrbody>0)
1482 . CALL drbycnt(nerby,npby)
1483 nb1d_t = nb1d
1484 IF(nb1d+nanim1d+nerby==0) GOTO 600
1485C-----------------------------------------------
1486C PART COUNT
1487C-----------------------------------------------
1488C
1489 DO i=1,numelt
1490 mater(ipartt(i))=3
1491 ENDDO
1492 DO i=1,numelp
1493 mater(ipartp(i))=3
1494 ENDDO
1495 DO i=1,numelr
1496 mater(ipartr(i))=3
1497 ENDDO
1498 DO i=1,numelx
1499 iprt=ipartx(i)
1500 IF (nfacptx(1,iprt)>0) THEN
1501 mater(iprt)=3
1502 ELSE
1503 mater(iprt)=0
1504 ENDIF
1505 ENDDO
1506C
1507 nbpart = 0
1508 DO i=1,npart
1509 nbpart = nbpart + mater(i)/3
1510 ENDDO
1511C
1512 DO i=1,nb1d + 1
1513 el2fa(i)=0
1514 ENDDO
1515C-----------------------------------------------
1516C WRITE CONTROL
1517C-----------------------------------------------
1518 CALL write_i_c(nb1d+nanim1d+nerby,1)
1519 CALL write_i_c(nbpart+nrbody,1)
1520 IF (dsanim==1) THEN
1521 nfe_ani=nfe_ani+nlevel
1522 ELSEIF (decani==1) THEN
1523 nfe_ani=nfe_ani+1
1524 ENDIF
1525 CALL write_i_c(nfe_ani,1)
1526 CALL write_i_c(nft_ani,1)
1527C FLAG FOR SKEW
1528 CALL write_i_c(1,1)
1529
1530C-----------------------------------------------
1531C PART SORT
1532C-----------------------------------------------
1533 CALL parsorf(iad ,iparg,ixt ,ixp ,ixr ,
1534 . mater,el2fa,
1535 . ipartt,ipartp,ipartr,nfacptx,ixedge)
1536 IF(nrbody>0) THEN
1537 CALL dparrby(lpby ,npby )
1538 ENDIF
1539C-----------------------------------------------
1540C OFF
1541C-----------------------------------------------
1542 CALL aniofff(elbuf_tab,iparg,waft,el2fa,
1543 . nb1d ,ioffx1)
1544 DO j=1,nerby
1545 CALL write_c_c(1,1)
1546 ENDDO
1547C-----------------------------------------------
1548C PART ADD
1549C-----------------------------------------------
1550 CALL write_i_c(iad,nbpart)
1551 DO i=1,nrbody
1552 nerbt(i)=0
1553 ENDDO
1554 nerby1=0
1555 DO irby=1,nrbody
1556 CALL donerby(irby,nerby1,npby,nerbt)
1557 CALL write_i_c(nb1d+nanim1d+nerby1,1)
1558 END DO
1559C-----------------------------------------------
1560C PART HEAD
1561C-----------------------------------------------
1562 DO i=1,npart
1563 IF(mater(i)==3)THEN
1564 WRITE(str,'(I8,A1)')ipart(4,i),':'
1565 DO j=1,9
1566 ctext(j)=ichar(str(j:j))
1567 ENDDO
1568 ib = 9
1569
1570 CALL fretitl2(titl,ipart(lipart1-ltitr+1,i),ltitl)
1571 DO j=1,ltitl
1572 IF(titl(j:j)/=' ') ib = j+9
1573 ctext(j+9)=ichar(titl(j:j))
1574 END DO
1575 ctext(ib+1)=0
1576 CALL write_c_c(ctext,10+ltitl)
1577
1578 ENDIF
1579 ENDDO
1580C
1581 IF (invstr<40) THEN
1582 DO irby=1,nrbody
1583 WRITE(str,'(I8,A2,A10)') irby,': ','Rigid Body'
1584 DO j=1,20
1585 ctext(j)=ichar(str(j:j))
1586 ENDDO
1587 ib = 20
1588 ctext(ib+1)=0
1589
1590 CALL write_c_c(ctext,10+ltitl)
1591 END DO
1592 ELSE
1593 DO irby=1,nrbody
1594 WRITE(str,'(I8,A2)') nom_opt(1,irby),': '
1595 DO j=1,10
1596 ctext(j)=ichar(str(j:j))
1597 ENDDO
1598
1599 CALL fretitl2(titl,nom_opt(lnopt1-ltitr+1,irby),
1600 . ltitl)
1601 ib = ltitl+9
1602 DO j=1,ltitl
1603 ctext(j+10)=ichar(titl(j:j))
1604 END DO
1605 ctext(ib+1)=0
1606 CALL write_c_c(ctext,10+ltitl)
1607 END DO
1608 END IF
1609C-----------------------------------------------
1610C ELEMENT MASS FOR MAS & FUNC
1611C-----------------------------------------------
1612 IF(anim_m==1.OR.anim_fe(3)==1)THEN
1613 CALL dmasanif(x ,d ,elbuf_tab,geo ,iparg,
1614 . ixt ,ixp ,ixr ,mas ,pm ,
1615 . el2fa ,nb1d )
1616 ENDIF
1617C-----------------------------------------------
1618C E(truss+..) FUNC TEXT
1619C-----------------------------------------------
1620 DO i=1,nmanim
1621 WRITE(ctmod,'(A7,I4,A8,I4,A18)')
1622 . 'Fxbody ',fxani(1,i),' - Mode ',fxani(2,i),' - Specific Energy'
1623 CALL ani_txt(ctmod,41)
1624 WRITE(ctmod,'(A7,I4,A8,I4,A12)')
1625 . 'Fxbody ',fxani(1,i),' - Mode ',fxani(2,i),' - Von Mises'
1626 CALL ani_txt(ctmod,35)
1627 WRITE(ctmod,'(A7,I4,A8,I4,A12)')
1628 . 'Fxbody ',fxani(1,i),' - Mode ',fxani(2,i),' - Stress X '
1629 CALL ani_txt(ctmod,35)
1630 WRITE(ctmod,'(A7,I4,A8,I4,A12)')
1631 . 'Fxbody ',fxani(1,i),' - Mode ',fxani(2,i),' - Stress Y '
1632 CALL ani_txt(ctmod,35)
1633 WRITE(ctmod,'(A7,I4,A8,I4,A12)')
1634 . 'Fxbody ',fxani(1,i),' - Mode ',fxani(2,i),' - Stress Z '
1635 CALL ani_txt(ctmod,35)
1636 WRITE(ctmod,'(A7,I4,A8,I4,A12)')
1637 . 'Fxbody ',fxani(1,i),' - Mode ',fxani(2,i),' - Stress XY'
1638 CALL ani_txt(ctmod,35)
1639 WRITE(ctmod,'(A7,I4,A8,I4,A12)')
1640 . 'Fxbody ',fxani(1,i),' - Mode ',fxani(2,i),' - Stress YZ'
1641 CALL ani_txt(ctmod,35)
1642 WRITE(ctmod,'(A7,I4,A8,I4,A12)')
1643 . 'Fxbody ',fxani(1,i),' - Mode ',fxani(2,i),' - Stress XZ'
1644 CALL ani_txt(ctmod,35)
1645 ENDDO
1646 IF (dsanim==1) THEN
1647 DO i=1,nlevel
1648 CALL ani_txt(ctitr(i),33)
1649 ENDDO
1650 ELSEIF (decani==1) THEN
1651 CALL ani_txt(ctitr(1),25)
1652 ENDIF
1653C-----------------------------------------------
1654C ELEMENT FUNC (truss+..)
1655C-----------------------------------------------
1656 ndma2= numnod*(min(1,anim_n(1)+outp_n(1))
1657 . +min(1,anim_n(2)+outp_n(2))
1658 . +min(1,anim_n(12)+outp_n(3)))
1659 DO i = 1,mx_ani
1660 ifunc = i
1661 IF(anim_fe(i)==1) THEN
1662
1663 CALL dfuncf(elbuf_tab,waft ,ifunc ,iparg ,geo ,
1664 . ixt ,ixp ,ixr ,mas ,pm ,
1665 . el2fa ,nb1d ,iad ,nbpart ,xfunc1)
1666 r4 = zero
1667 DO j=1,nerby
1668 CALL write_r_c(r4,1)
1669 ENDDO
1670 ENDIF
1671 ENDDO
1672C
1673 nmfunc(1)=3
1674 nmfunc(2)=7
1675 nmfunc(3)=14
1676 nmfunc(4)=15
1677 nmfunc(5)=16
1678 nmfunc(6)=17
1679 nmfunc(7)=18
1680 nmfunc(8)=19
1681 DO i=1,nmanim
1682 DO j=1,8
1683 ifunc=nmfunc(j)
1684! CALL DFUNCF(MBUFEL(1,I), WAFT, IFUNC, IPARG, GEO,
1685! . IXT, IXP, IXR, MAS, PM,
1686! . EL2FA, NB1D, IAD, NBPART,
1687! . XFUNC1)
1688 r4 = zero
1689 DO k=1,nerby
1690 CALL write_r_c(r4,1)
1691 ENDDO
1692 ENDDO
1693 ENDDO
1694 IF (dsanim==1) THEN
1695 DO i=1,nlevel
1696 DO j=1,nb1d
1697 func(j)=zero
1698 ENDDO
1699C 1D elements
1700 off=1+numels+numelq+numelc
1701 CALL delsub(nlevel, elsub, i, off, numelt+numelp+numelr,
1702 . el2fa, func )
1703C
1704 DO j=1,nb1d
1705 r4=func(j)
1706 CALL write_r_c(r4,1)
1707 ENDDO
1708 r4 = zero
1709 DO j=1,nanim1d
1710 CALL write_r_c(r4,1)
1711 ENDDO
1712 DO j=1,nerby
1713 CALL write_r_c(r4,1)
1714 ENDDO
1715 ENDDO
1716 ELSEIF (decani==1) THEN
1717 DO i=1,nb1d
1718 func(i)=zero
1719 ENDDO
1720C 1D elements
1721 off=1+numels+numelq+numelc
1722 CALL delsub(1, cep, 1, off, numelt+numelp+numelr,
1723 . el2fa, func)
1724C
1725 DO i=1,nb1d
1726 r4=func(i)
1727 CALL write_r_c(r4,1)
1728 ENDDO
1729 r4=zero
1730 DO i=1,nanim1d
1731 CALL write_r_c(r4,1)
1732 ENDDO
1733 DO i=1,nerby
1734 CALL write_r_c(r4,1)
1735 ENDDO
1736 ENDIF
1737C-----------------------------------------------
1738C SKEW
1739C-----------------------------------------------
1740 lrbuf = 0
1741
1742 CALL aniskewf(geo,skew,iparg,ixr,lrbuf)
1743 DO i=1,nanim1d
1744 CALL write_i_c(0,1)
1745 ENDDO
1746 DO j=1,nerby
1747 CALL write_i_c(0,1)
1748 ENDDO
1749C-----------------------------------------------
1750C ELEMENT MASS
1751C-----------------------------------------------
1752 IF(anim_m==1)THEN
1753 DO i=1,nb1d
1754 r4 = mas(i)
1755 CALL write_r_c(r4,1)
1756 ENDDO
1757 r4 = 0.
1758 DO j=1,nerby
1759 CALL write_r_c(r4,1)
1760 ENDDO
1761 ENDIF
1762C-----------------------------------------------
1763C ELEMENT NUMBERING
1764C-----------------------------------------------
1765 CALL delnumbf(iparg,ixt ,ixp ,ixr ,
1766 . el2fa,nb1d ,waft ,
1767 . inumx1 )
1768 DO j=1,nerby
1769 CALL write_i_c(0,1)
1770 ENDDO
1771C-----------------------------------------------
1772C HIERARCHY
1773C-----------------------------------------------
1774 DO i=1,npart
1775 IF(mater(i)==3)THEN
1776 IF (ipart(3,i)<nsubs) THEN
1777 CALL write_i_c(ipart(3,i)-1,1)
1778 ELSE
1779 CALL write_i_c(nsubs
1780 . +min(1,nsect)+min(1,nrbody)+min(1,nrwall)
1781 . +min(1,nsurg+nsmad)-1,1)
1782 END IF
1783 END IF
1784 ENDDO
1785c Subset Rbodies == NSUBS
1786 DO i=1,nrbody
1787 CALL write_i_c(nsubs-1,1)
1788 END DO
1789 DO i=1,npart
1790 IF(mater(i)==3)CALL write_i_c(ipart(1,i),1)
1791 ENDDO
1792 DO i=1,nrbody
1793 CALL write_i_c(0,1)
1794 ENDDO
1795 DO i=1,npart
1796 IF(mater(i)==3)CALL write_i_c(ipart(2,i),1)
1797 ENDDO
1798 DO i=1,nrbody
1799 CALL write_i_c(0,1)
1800 ENDDO
1801C=======================================================================
1802 600 CONTINUE
1803C=======================================================================
1804C
1805C HIERARCHY
1806C
1807C=======================================================================
1808 j=0
1809 DO i=1,npart
1810 IF(mater(i)==1)THEN
1811 j=j+1
1812 mater(i)=j
1813 ELSE
1814 mater(i)=-mater(i)
1815 ENDIF
1816 ENDDO
1817 m01=j
1818 j=j+ncuts+nrwall+nsect+nsurg+nsmad
1819 m1=j
1820 DO i=1,npart
1821 IF(mater(i)==-2)THEN
1822 j=j+1
1823 mater(i)=j
1824 ENDIF
1825 ENDDO
1826 m2=j
1827 DO i=1,npart
1828 IF(mater(i)==-3)THEN
1829 j=j+1
1830 mater(i)=j
1831 ENDIF
1832 ENDDO
1833 m3=j+nrbody
1834C-----------------------------------------------
1835C WRITE CONTROL
1836C-----------------------------------------------
1837 CALL write_i_c(nsubs
1838 . +min(1,nsect)+min(1,nrbody)+min(1,nrwall)
1839 . +min(1,nsurg+nsmad)+nfvsubs,1)
1840C-----------------------------------------------
1841C SUBSET HEAD/PARENT/
1842C-----------------------------------------------
1843 IF (nsubs==1) THEN
1844C-----------------------------
1845C ONE SEUL SUBSET OU INPUT V31
1846C-----------------------------
1847 mxsubs=1
1848C-----------------
1849C SUBSET RBODIES
1850C-----------------
1851 IF (nrbody>0) THEN
1852 WRITE(str,'(I8,A14)')mxsubs+1,':RBODIES MODEL'
1853 DO j=1,22
1854 ctext(j)=ichar(str(j:j))
1855 ENDDO
1856 ctext(23)=0
1857 CALL write_c_c(ctext,10+ltitl)
1858C SUBSET PARENT == GLOBAL
1859 CALL write_i_c(nsubs
1860 . +min(1,nsect)+min(1,nrbody)+min(1,nrwall)
1861 . +min(1,nsurg+nsmad)+nfvsubs-1,1)
1862C #SUBSETS FILS
1863 CALL write_i_c(0,1)
1864C SUBSETS FILS
1865C #PARTS FILLES
1866 n1=0
1867 n2=0
1868 n3=nrbody
1869C PARTS FILLES 2D
1870 CALL write_i_c(n1,1)
1871C PARTS FILLES 3D
1872 CALL write_i_c(n2,1)
1873C PARTS FILLES 1D
1874 CALL write_i_c(n3,1)
1875 DO j=nrbody,1,-1
1876 CALL write_i_c(m3-j-m2,1)
1877 ENDDO
1878 END IF
1879C-----------------
1880C SUBSET SECTIONS
1881C-----------------
1882 IF (nsect>0) THEN
1883 WRITE(str,'(I8,A15)')mxsubs+min(1,nrbody)+1,':SECTIONS MODEL'
1884 DO j=1,23
1885 ctext(j)=ichar(str(j:j))
1886 ENDDO
1887 ctext(24)=0
1888 CALL write_c_c(ctext,10+ltitl)
1889C SUBSET PARENT == GLOBAL
1890 CALL write_i_c(nsubs
1891 . +min(1,nsect)+min(1,nrbody)+min(1,nrwall)
1892 . +min(1,nsurg+nsmad)+nfvsubs-1,1)
1893C #SUBSETS FILS
1894 CALL write_i_c(0,1)
1895C SUBSETS FILS
1896C #PARTS FILLES
1897 n1=nsect
1898 n2=0
1899 n3=0
1900C PARTS FILLES 2D
1901 CALL write_i_c(n1,1)
1902 DO j=nsect,1,-1
1903 CALL write_i_c(m1-nsurg-nsmad-nrwall-j,1)
1904 ENDDO
1905C PARTS FILLES 3D
1906 CALL write_i_c(n2,1)
1907C PARTS FILLES 1D
1908 CALL write_i_c(n3,1)
1909 END IF
1910C-----------------
1911C SUBSET RWALLS
1912C-----------------
1913 IF (nrwall>0) THEN
1914 WRITE(str,'(I8,A13)')mxsubs
1915 . +min(1,nsect)+min(1,nrbody)+1,':RWALLS MODEL'
1916 DO j=1,21
1917 ctext(j)=ichar(str(j:j))
1918 ENDDO
1919 ctext(22)=0
1920 CALL write_c_c(ctext,10+ltitl)
1921C SUBSET PARENT == GLOBAL
1922 CALL write_i_c(nsubs
1923 . +min(1,nsect)+min(1,nrbody)+min(1,nrwall)
1924 . +min(1,nsurg+nsmad)+nfvsubs-1,1)
1925C #SUBSETS FILS
1926 CALL write_i_c(0,1)
1927C SUBSETS FILS
1928C #PARTS FILLES
1929 n1=nrwall
1930 n2=0
1931 n3=0
1932C PARTS FILLES 2D
1933 CALL write_i_c(n1,1)
1934 DO j=nrwall,1,-1
1935 CALL write_i_c(m1-nsurg-nsmad-j,1)
1936 ENDDO
1937C PARTS FILLES 3D
1938 CALL write_i_c(n2,1)
1939C PARTS FILLES 1D
1940 CALL write_i_c(n3,1)
1941 END IF
1942C-----------------
1943C SUBSET SURFACES
1944C-----------------
1945 IF (nsurg+nsmad>0) THEN
1946 WRITE(str,'(I8,A15)')mxsubs
1947 . +min(1,nsect)+min(1,nrbody)+min(1,nrwall)+1,
1948 . ':SURFACES MODEL'
1949 DO j=1,23
1950 ctext(j)=ichar(str(j:j))
1951 ENDDO
1952 ctext(24)=0
1953 CALL write_c_c(ctext,10+ltitl)
1954C SUBSET PARENT == GLOBAL
1955 CALL write_i_c(nsubs
1956 . +min(1,nsect)+min(1,nrbody)+min(1,nrwall)
1957 . +min(1,nsurg+nsmad)+nfvsubs-1,1)
1958C #SUBSETS FILS
1959 CALL write_i_c(0,1)
1960C SUBSETS FILS
1961C #PARTS FILLES
1962 n1=nsurg+nsmad
1963 n2=0
1964 n3=0
1965C PARTS FILLES 2D
1966 CALL write_i_c(n1,1)
1967 DO j=nsurg+nsmad,1,-1
1968 CALL write_i_c(m1-j,1)
1969 ENDDO
1970C PARTS FILLES 3D
1971 CALL write_i_c(n2,1)
1972C PARTS FILLES 1D
1973 CALL write_i_c(n3,1)
1974 END IF
1975C-----------------
1976C SUBSETS FVMBAG
1977C-----------------
1978 IF (nfvsubs>0) THEN
1979 ii=nsubs
1980 . +min(1,nsect)+min(1,nrbody)+min(1,nrwall)
1981 . +min(1,nsurg+nsmad)
1982 offpart=nbpart2d
1983 DO i=1,nfvbag
1984 IF (fvdata(i)%NPOLH_ANIM>0) THEN
1985 ii=ii+1
1986 WRITE(str,'(I8,A11,I8)')
1987 . ii,':FVMBAG ID ',fvdata(i)%ID
1988 DO j=1,27
1989 ctext(j)=ichar(str(j:j))
1990 ENDDO
1991 ctext(28)=0
1992 CALL write_c_c(ctext,10+ltitl)
1993C SUBSET PARENT == GLOBAL
1994 CALL write_i_c(nsubs
1995 . +min(1,nsect)+min(1,nrbody)+min(1,nrwall)
1996 . +min(1,nsurg+nsmad)+nfvsubs-1,1)
1997C #SUBSETS FILS
1998 CALL write_i_c(0,1)
1999C PARTS FILLES 2D
2000 CALL write_i_c(fvdata(i)%NPOLH_ANIM,1)
2001 DO j=1,fvdata(i)%NPOLH_ANIM
2002 CALL write_i_c(offpart+j-1,1)
2003 ENDDO
2004 offpart=offpart+fvdata(i)%NPOLH_ANIM
2005C PARTS FILLES 3D
2006 CALL write_i_c(0,1)
2007C PARTS FILLES 1D
2008 CALL write_i_c(0,1)
2009 ENDIF
2010 ENDDO
2011 ENDIF
2012C--------------
2013C GLOBAL MODEL
2014C--------------
2015 WRITE(str,'(I8,A13)')1,':GLOBAL MODEL'
2016 DO j=1,21
2017 ctext(j)=ichar(str(j:j))
2018 ENDDO
2019 ctext(22)=0
2020 CALL write_c_c(ctext,10+ltitl)
2021C SUBSET PARENT
2022 CALL write_i_c(-1,1)
2023C #SUBSETS FILS
2024 CALL write_i_c(min(1,nsect)+min(1,nrbody)+min(1,nrwall)
2025 . +min(1,nsurg+nsmad)+nfvsubs,1)
2026C SUBSETS FILS
2027 IF (nrbody>0)
2028 . CALL write_i_c(nsubs-1,1)
2029 IF (nsect>0)
2030 . CALL write_i_c(nsubs+min(1,nrbody)-1,1)
2031 IF (nrwall>0)
2032 . CALL write_i_c(nsubs+min(1,nsect)+min(1,nrbody)-1,1)
2033 IF (nsurg+nsmad>0)
2034 . CALL write_i_c(nsubs+min(1,nsect)+min(1,nrbody)
2035 . +min(1,nrwall)-1,1)
2036 IF (nfvsubs>0) THEN
2037 ii=min(1,nsect)+min(1,nrbody)+min(1,nrwall)
2038 . +min(1,nsurg+nsmad)+1
2039 DO i=1,nfvbag
2040 ii=ii+1
2041 CALL write_i_c(ii-1,1)
2042 ENDDO
2043 ENDIF
2044C #PARTS FILLES
2045 n1=0
2046 n2=0
2047 n3=0
2048 DO k=1,npart
2049 IF(mater(k)>0.AND.mater(k)<=m01)THEN
2050 n1=n1+1
2051 ELSEIF(mater(k)>m1.AND.mater(k)<=m2)THEN
2052 n2=n2+1
2053 ELSEIF(mater(k)>m2)THEN
2054 n3=n3+1
2055 ENDIF
2056 ENDDO
2057C CUTS IN THE GLOBAL SUBSET
2058 n1=n1+ncuts
2059C PARTS FILLES 2D
2060 CALL write_i_c(n1,1)
2061 DO k=1,npart
2062 IF(mater(k)>0.AND.mater(k)<=m01)
2063 . CALL write_i_c(mater(k)-1,1)
2064 ENDDO
2065C CUTS IN THE GLOBAL SUBSET
2066 DO j=1,ncuts
2067 CALL write_i_c(m1-nrwall-nsect-nsurg-nsmad-j,1)
2068 ENDDO
2069C PARTS FILLES 3D
2070 CALL write_i_c(n2,1)
2071 DO k=1,npart
2072 IF(mater(k)>m1.AND.mater(k)<=m2)
2073 . CALL write_i_c(mater(k)-m1-1,1)
2074 ENDDO
2075C PARTS FILLES 1D
2076 CALL write_i_c(n3,1)
2077 DO k=1,npart
2078 IF(mater(k)>m2)CALL write_i_c(mater(k)-m2-1,1)
2079 ENDDO
2080 ELSE
2081C----------------
2082C +SIEURS SUBSET ET INPUT V4.X
2083C----------------
2084 mxsubs=0
2085 DO i=1,nsubs-1
2086 IF (subset(i)%ID > mxsubs) mxsubs=subset(i)%ID
2087 WRITE(str,'(I8,A1)')subset(i)%ID,':'
2088 DO j=1,9
2089 ctext(j)=ichar(str(j:j))
2090 ENDDO
2091 ib = 9
2092 titl = subset(i)%TITLE
2093 DO j=1,ltitl
2094 IF(titl(j:j)/=' ') ib = j+9
2095 ctext(j+9)=ichar(titl(j:j))
2096 ENDDO
2097 ctext(ib+1)=0
2098 CALL write_c_c(ctext,10+ltitl)
2099C SUBSET PARENT
2100 IF (subset(i)%PARENT < nsubs) THEN
2101 CALL write_i_c(subset(i)%PARENT-1,1)
2102 ELSE
2103 CALL write_i_c(subset(i)%PARENT
2104 . +min(1,nsect)+min(1,nrbody)+min(1,nrwall)
2105 . +min(1,nsurg+nsmad)+nfvsubs-1,1)
2106 END IF
2107C #SUBSETS FILS
2108 CALL write_i_c(subset(i)%NCHILD,1)
2109C SUBSETS FILS
2110 DO j=1,subset(i)%NCHILD
2111 CALL write_i_c(subset(i)%CHILD(j)-1,1)
2112 ENDDO
2113C #PARTS FILLES
2114 n1=0
2115 n2=0
2116 n3=0
2117 DO j=1,subset(i)%NPART
2118 k = subset(i)%PART(j)
2119 IF(mater(k)>0.AND.mater(k)<=m01)THEN
2120 n1=n1+1
2121 ELSEIF(mater(k)>m1.AND.mater(k)<=m2)THEN
2122 n2=n2+1
2123 ELSEIF(mater(k)>m2)THEN
2124 n3=n3+1
2125 ENDIF
2126 ENDDO
2127C PARTS FILLES 2D
2128 CALL write_i_c(n1,1)
2129 DO j=1,subset(i)%NPART
2130 k = subset(i)%PART(j)
2131 IF(mater(k)>0.AND.mater(k)<=m01)
2132 . CALL write_i_c(mater(k)-1,1)
2133 ENDDO
2134C PARTS FILLES 3D
2135 CALL write_i_c(n2,1)
2136 DO j=1,subset(i)%NPART
2137 k = subset(i)%PART(j)
2138 IF(mater(k)>m1.AND.mater(k)<=m2)
2139 . CALL write_i_c(mater(k)-m1-1,1)
2140 ENDDO
2141C PARTS FILLES 1D
2142 CALL write_i_c(n3,1)
2143 DO j=1,subset(i)%NPART
2144 k = subset(i)%PART(j)
2145 IF(mater(k)>m2)CALL write_i_c(mater(k)-m2-1,1)
2146 ENDDO
2147 ENDDO
2148C-----------------
2149C SUBSET RBODIES
2150C-----------------
2151 IF (nrbody>0) THEN
2152 WRITE(str,'(I8,A14)')mxsubs+1,':RBODIES MODEL'
2153 DO j=1,22
2154 ctext(j)=ichar(str(j:j))
2155 ENDDO
2156 ctext(23)=0
2157 CALL write_c_c(ctext,10+ltitl)
2158C SUBSET PARENT == GLOBAL
2159 CALL write_i_c(nsubs
2160 . +min(1,nsect)+min(1,nrbody)+min(1,nrwall)
2161 . +min(1,nsurg+nsmad)+nfvsubs-1,1)
2162C #SUBSETS FILS
2163 CALL write_i_c(0,1)
2164C SUBSETS FILS
2165C #PARTS FILLES
2166 n1=0
2167 n2=0
2168 n3=nrbody
2169C PARTS FILLES 2D
2170 CALL write_i_c(n1,1)
2171C PARTS FILLES 3D
2172 CALL write_i_c(n2,1)
2173C PARTS FILLES 1D
2174 CALL write_i_c(n3,1)
2175 DO j=nrbody,1,-1
2176 CALL write_i_c(m3-j-m2,1)
2177 ENDDO
2178 END IF
2179C-----------------
2180C SUBSET SECTIONS
2181C-----------------
2182 IF (nsect>0) THEN
2183 WRITE(str,'(I8,A15)')mxsubs+min(1,nrbody)+1,':SECTIONS MODEL'
2184 DO j=1,23
2185 ctext(j)=ichar(str(j:j))
2186 ENDDO
2187 ctext(24)=0
2188 CALL write_c_c(ctext,10+ltitl)
2189C SUBSET PARENT == GLOBAL
2190 CALL write_i_c(nsubs
2191 . +min(1,nsect)+min(1,nrbody)+min(1,nrwall)
2192 . +min(1,nsurg+nsmad)+nfvsubs-1,1)
2193C #SUBSETS FILS
2194 CALL write_i_c(0,1)
2195C SUBSETS FILS
2196C #PARTS FILLES
2197 n1=nsect
2198 n2=0
2199 n3=0
2200C PARTS FILLES 2D
2201 CALL write_i_c(n1,1)
2202 DO j=nsect,1,-1
2203 CALL write_i_c(m1-nsurg-nsmad-nrwall-j,1)
2204 ENDDO
2205C PARTS FILLES 3D
2206 CALL write_i_c(n2,1)
2207C PARTS FILLES 1D
2208 CALL write_i_c(n3,1)
2209 END IF
2210C-----------------
2211C SUBSET RWALLS
2212C-----------------
2213 IF (nrwall>0) THEN
2214 WRITE(str,'(I8,A13)')mxsubs
2215 . +min(1,nsect)+min(1,nrbody)+1,':RWALLS MODEL'
2216 DO j=1,21
2217 ctext(j)=ichar(str(j:j))
2218 ENDDO
2219 ctext(22)=0
2220 CALL write_c_c(ctext,10+ltitl)
2221C SUBSET PARENT == GLOBAL
2222 CALL write_i_c(nsubs
2223 . +min(1,nsect)+min(1,nrbody)+min(1,nrwall)
2224 . +min(1,nsurg+nsmad)+nfvsubs-1,1)
2225C #SUBSETS FILS
2226 CALL write_i_c(0,1)
2227C SUBSETS FILS
2228C #PARTS FILLES
2229 n1=nrwall
2230 n2=0
2231 n3=0
2232C PARTS FILLES 2D
2233 CALL write_i_c(n1,1)
2234 DO j=nrwall,1,-1
2235 CALL write_i_c(m1-nsurg-nsmad-j,1)
2236 ENDDO
2237C PARTS FILLES 3D
2238 CALL write_i_c(n2,1)
2239C PARTS FILLES 1D
2240 CALL write_i_c(n3,1)
2241 END IF
2242C-----------------
2243C SUBSET SURFACES
2244C-----------------
2245 IF (nsurg+nsmad>0) THEN
2246 WRITE(str,'(I8,A15)')mxsubs
2247 . +min(1,nsect)+min(1,nrbody)+min(1,nrwall)+1,
2248 . ':SURFACES MODEL'
2249 DO j=1,23
2250 ctext(j)=ichar(str(j:j))
2251 ENDDO
2252 ctext(24)=0
2253 CALL write_c_c(ctext,10+ltitl)
2254C SUBSET PARENT == GLOBAL
2255 CALL write_i_c(nsubs
2256 . +min(1,nsect)+min(1,nrbody)+min(1,nrwall)
2257 . +min(1,nsurg+nsmad)+nfvsubs-1,1)
2258C #SUBSETS FILS
2259 CALL write_i_c(0,1)
2260C SUBSETS FILS
2261C #PARTS FILLES
2262 n1=nsurg+nsmad
2263 n2=0
2264 n3=0
2265C PARTS FILLES 2D
2266 CALL write_i_c(n1,1)
2267 DO j=nsurg+nsmad,1,-1
2268 CALL write_i_c(m1-j,1)
2269 ENDDO
2270C PARTS FILLES 3D
2271 CALL write_i_c(n2,1)
2272C PARTS FILLES 1D
2273 CALL write_i_c(n3,1)
2274 END IF
2275C-----------------
2276C SUBSETS FVMBAG
2277C-----------------
2278 IF (nfvsubs>0) THEN
2279 ii=nsubs
2280 . +min(1,nsect)+min(1,nrbody)+min(1,nrwall)
2281 . +min(1,nsurg+nsmad)-1
2282 offpart=nbpart2d
2283 DO i=1,nfvbag
2284 IF (fvdata(i)%NPOLH_ANIM>0) THEN
2285 ii=ii+1
2286 WRITE(str,'(I8,A11,I8)')
2287 . ii,':FVMBAG ID ',fvdata(i)%ID
2288 DO j=1,27
2289 ctext(j)=ichar(str(j:j))
2290 ENDDO
2291 ctext(28)=0
2292 CALL write_c_c(ctext,10+ltitl)
2293C SUBSET PARENT == GLOBAL
2294 CALL write_i_c(nsubs
2295 . +min(1,nsect)+min(1,nrbody)+min(1,nrwall)
2296 . +min(1,nsurg+nsmad)+nfvsubs-1,1)
2297C #SUBSETS FILS
2298 CALL write_i_c(0,1)
2299C PARTS FILLES 2D
2300 CALL write_i_c(fvdata(i)%NPOLH_ANIM,1)
2301 DO j=1,fvdata(i)%NPOLH_ANIM
2302 CALL write_i_c(offpart+j-1,1)
2303 ENDDO
2304 offpart=offpart+fvdata(i)%NPOLH_ANIM
2305C PARTS FILLES 3D
2306 CALL write_i_c(0,1)
2307C PARTS FILLES 1D
2308 CALL write_i_c(0,1)
2309 ENDIF
2310 ENDDO
2311 ENDIF
2312C--------------
2313C GLOBAL MODEL
2314C--------------
2315 WRITE(str,'(I8,A1)') subset(nsubs)%ID,':'
2316 DO j=1,9
2317 ctext(j)=ichar(str(j:j))
2318 ENDDO
2319 ib = 9
2320 titl = subset(nsubs)%TITLE
2321 DO j=1,ltitl
2322 IF(titl(j:j)/=' ') ib = j+9
2323 ctext(j+9)=ichar(titl(j:j))
2324 ENDDO
2325 ctext(ib+1)=0
2326 CALL write_c_c(ctext,10+ltitl)
2327C SUBSET PARENT
2328 CALL write_i_c(subset(nsubs)%PARENT-1,1)
2329C #SUBSETS FILS
2330 CALL write_i_c(subset(nsubs)%NCHILD
2331 . +min(1,nsect)+min(1,nrbody)+min(1,nrwall)
2332 . +min(1,nsurg+nsmad)+nfvsubs,1)
2333C SUBSETS FILS
2334 DO j=1,subset(nsubs)%NCHILD
2335 CALL write_i_c(subset(nsubs)%CHILD(j)-1,1)
2336 ENDDO
2337 IF (nrbody>0)
2338 . CALL write_i_c(nsubs-1,1)
2339 IF (nsect>0)
2340 . CALL write_i_c(nsubs+min(1,nrbody)-1,1)
2341 IF (nrwall>0)
2342 . CALL write_i_c(nsubs+min(1,nsect)+min(1,nrbody)-1,1)
2343 IF (nsurg+nsmad>0)
2344 . CALL write_i_c(nsubs+min(1,nsect)+min(1,nrbody)
2345 . +min(1,nrwall)-1,1)
2346 IF (nfvsubs>0) THEN
2347 ii=nsubs+min(1,nsect)+min(1,nrbody)+min(1,nrwall)
2348 . +min(1,nsurg+nsmad)
2349 DO i=1,nfvbag
2350 CALL write_i_c(ii-1,1)
2351 ii=ii+1
2352 ENDDO
2353 ENDIF
2354C #PARTS FILLES
2355 n1=0
2356 n2=0
2357 n3=0
2358 DO j=1,subset(i)%NPART
2359 k = subset(i)%PART(j)
2360 IF(mater(k)>0.AND.mater(k)<=m01)THEN
2361 n1=n1+1
2362 ELSEIF(mater(k)>m1.AND.mater(k)<=m2)THEN
2363 n2=n2+1
2364 ELSEIF(mater(k)>m2)THEN
2365 n3=n3+1
2366 ENDIF
2367 ENDDO
2368C CUTS IN THE GLOBAL SUBSET
2369 n1=n1+ncuts
2370C PARTS FILLES 2D
2371 CALL write_i_c(n1,1)
2372 DO j=1,subset(i)%NPART
2373 k = subset(i)%PART(j)
2374 IF(mater(k)>0.AND.mater(k)<=m01)
2375 . CALL write_i_c(mater(k)-1,1)
2376 ENDDO
2377C CUTS DANS LE SUBSET GLOBAL
2378 DO j=1,ncuts
2379 CALL write_i_c(m1-nrwall-nsect-nsurg-nsmad-j,1)
2380 ENDDO
2381C PARTS FILLES 3D
2382 CALL write_i_c(n2,1)
2383 DO j=1,subset(i)%NPART
2384 k = subset(i)%PART(j)
2385 IF(mater(k)>m1.AND.mater(k)<=m2)
2386 . CALL write_i_c(mater(k)-m1-1,1)
2387 ENDDO
2388C PARTS FILLES 1D
2389 CALL write_i_c(n3,1)
2390 DO j=1,subset(i)%NPART
2391 k = subset(i)%PART(j)
2392 IF(mater(k)>m2)CALL write_i_c(mater(k)-m2-1,1)
2393 ENDDO
2394 ENDIF
2395C-----------------------------------------------
2396C WRITE CONTROL
2397C-----------------------------------------------
2398 CALL write_i_c(nummat+1,1)
2399 CALL write_i_c(numgeo+1,1)
2400C-----------------------------------------------
2401C MAT HEAD
2402C-----------------------------------------------
2403 CALL ani_txt50('Dummy Material',14)
2404 DO i=1,nummat
2405 WRITE(str,'(I8,A1)') ipm(1,i),':'
2406 DO j=1,9
2407 ctext(j)=ichar(str(j:j))
2408 ENDDO
2409 ib = 9
2410 CALL fretitl2(titl,ipm(npropmi-ltitr+1,i),ltitl)
2411 DO j=1,ltitl
2412 IF(titl(j:j)/=' ') ib = j+9
2413 ctext(j+9)=ichar(titl(j:j))
2414 ENDDO
2415 ctext(ib+1)=0
2416 CALL write_c_c(ctext,10+ltitl)
2417 ENDDO
2418C-----------------------------------------------
2419C MAT TYPE
2420C-----------------------------------------------
2421 CALL write_i_c(0,1)
2422 DO i=1,nummat
2423 CALL write_i_c(nint(pm(19,i)),1)
2424 ENDDO
2425C-----------------------------------------------
2426C PROP HEAD
2427C-----------------------------------------------
2428 CALL ani_txt50('Dummy Property',14)
2429 DO i=1,numgeo
2430 WRITE(str,'(I8,A1)') igeo(1,i),':'
2431 DO j=1,9
2432 ctext(j)=ichar(str(j:j))
2433 ENDDO
2434 ib = 9
2435 CALL fretitl2(titl,igeo(npropgi-ltitr+1,i),ltitl)
2436 DO j=1,ltitl
2437 IF(titl(j:j)/=' ') ib = j+9
2438 ctext(j+9)=ichar(titl(j:j))
2439 ENDDO
2440 ctext(ib+1)=0
2441 CALL write_c_c(ctext,10+ltitl)
2442 ENDDO
2443C-----------------------------------------------
2444C PROP TYPE
2445C-----------------------------------------------
2446 CALL write_i_c(0,1)
2447 DO i=1,numgeo
2448 CALL write_i_c(nint(geo(12,i)),1)
2449 ENDDO
2450C=======================================================================
2451C
2452C Additional particles description, case of /ANIM/VERS/44 only.
2453C
2454C=======================================================================
2455 IF(isph3d==1.OR.numsph_t+maxpjet==0) GOTO 700
2456C-----------------------------------------------
2457C PREPARE Subset outings: Part girls meshless
2458C-----------------------------------------------
2459 DO i=1,npart
2460 mater(i)=-mater(i)
2461 ENDDO
2462C-----------------------------------------------
2463C PART COUNT
2464C-----------------------------------------------
2465 DO i=1,numsph+maxpjet
2466 mater(ipartsp(i))=4
2467 el2fa(i)=0
2468 ENDDO
2469C
2470 nbpart = 0
2471 DO i=1,npart
2472 IF(mater(i)==4)nbpart = nbpart + 1
2473 ENDDO
2474C-----------------------------------------------
2475C WRITE CONTROL
2476C-----------------------------------------------
2477 CALL write_i_c(numsph+maxpjet,1)
2478 CALL write_i_c(nbpart,1)
2479 CALL write_i_c(nse_ani+1,1)
2480 CALL write_i_c(nst_ani,1)
2481C-----------------------------------------------
2482C PART SORT
2483C-----------------------------------------------
2484 CALL parsor0(iad ,iparg ,mater ,el2fa ,
2485 3 kxsp ,ipartsp )
2486C-----------------------------------------------
2487C OFF
2488C-----------------------------------------------
2489 nnn = numsph+maxpjet
2490 CALL anioff0(elbuf_tab ,iparg ,waft ,el2fa ,nnn ,
2491 1 swaft, sph2sol)
2492C-----------------------------------------------
2493C PART ADD
2494C-----------------------------------------------
2495 CALL write_i_c(iad,nbpart)
2496C-----------------------------------------------
2497C PART HEAD
2498C-----------------------------------------------
2499 DO i=1,npart
2500 IF(mater(i)==4)THEN
2501 WRITE(str,'(I8,A1)')ipart(4,i),':'
2502 DO j=1,9
2503 ctext(j)=ichar(str(j:j))
2504 ENDDO
2505 ib = 9
2506 CALL fretitl2(titl,ipart(lipart1-ltitr+1,i),ltitl)
2507 DO j=1,ltitl
2508 IF(titl(j:j)/=' ') ib = j+9
2509 ctext(j+9)=ichar(titl(j:j))
2510 ENDDO
2511 ctext(ib+1)=0
2512 CALL write_c_c(ctext,10+ltitl)
2513 ENDIF
2514 ENDDO
2515C-----------------------------------------------
2516C ELEMENT MASS FOR MAS & FUNC
2517C-----------------------------------------------
2518 IF(anim_m==1.OR.anim_se(3)==1.OR.
2519 . anim_se(25)==1)THEN
2520 CALL dmasani0(elbuf_tab ,iparg ,
2521 2 mas ,pm ,el2fa ,ipart ,ipartsp )
2522 ENDIF
2523C-----------------------------------------------
2524C FUNC TEXT
2525C-----------------------------------------------
2526 ctext(81)=0
2527 CALL ani_txt('Diameter',8)
2528 IF (dsanim==1) THEN
2529 DO i=1,nlevel
2530 CALL ani_txt(ctitr(i),33)
2531 ENDDO
2532 ELSEIF (decani==1) THEN
2533 CALL ani_txt(ctitr(1),25)
2534 ENDIF
2535C-----------------------------------------------
2536C ELEMENT FUNC (SPH)
2537C-----------------------------------------------
2538 nnn = numsph+maxpjet
2539 DO i = 0,mx_ani
2540 ifunc = i
2541 IF(ifunc==0.OR.(ifunc>0.AND.anim_se(i)==1)) THEN
2542 CALL dfunc0(elbuf_tab ,waft ,ifunc ,iparg ,pm ,
2543 . el2fa ,nnn ,spbuf ,ipart ,ipartsp )
2544 ENDIF
2545 ENDDO
2546 IF (decani==1) THEN
2547 DO i=1,numsph
2548 func(i)=zero
2549 ENDDO
2550C SPH particles
2551 off=1
2552 CALL delsub(1, cepsp, 1, off, numsph,
2553 . el2fa, func )
2554C
2555 DO i=1,numsph
2556 r4=func(i)
2557 CALL write_r_c(r4,1)
2558 ENDDO
2559 r4=zero
2560 DO i=1,maxpjet
2561 CALL write_r_c(r4,1)
2562 ENDDO
2563 ENDIF
2564C-----------------------------------------------
2565C 3D TENSOR (SPH)
2566C-----------------------------------------------
2567 DO i = 1,mx_ani
2568 ifunc = i
2569 IF(anim_st(i)==1)THEN
2570 CALL tensor0(elbuf_tab ,iparg ,ifunc ,pm ,el2fa ,
2571 2 nnn ,waft ,ipart ,ipartsp )
2572 ENDIF
2573 ENDDO
2574C-----------------------------------------------
2575C ELEMENT MASS (SPH)
2576C-----------------------------------------------
2577 IF(anim_m==1)THEN
2578 DO i=1,nnn
2579 r4 = mas(i)
2580 CALL write_r_c(r4,1)
2581 ENDDO
2582 ENDIF
2583C-----------------------------------------------
2584C NUMBERING (SPH)
2585C-----------------------------------------------
2586 CALL delnumb0(iparg,el2fa,nnn ,waft,kxsp )
2587C-----------------------------------------------
2588C HIERARCHY
2589C-----------------------------------------------
2590 DO i=1,npart
2591 IF(mater(i)==4)THEN
2592 IF (ipart(3,i)<nsubs) THEN
2593 CALL write_i_c(ipart(3,i)-1,1)
2594 ELSE
2595 CALL write_i_c(nsubs
2596 . +min(1,nsect)+min(1,nrbody)+min(1,nrwall)
2597 . +min(1,nsurg+nsmad)-1,1)
2598 END IF
2599 END IF
2600 ENDDO
2601 DO i=1,npart
2602 IF(mater(i)==4)CALL write_i_c(ipart(1,i),1)
2603 ENDDO
2604 DO i=1,npart
2605 IF(mater(i)==4)CALL write_i_c(ipart(2,i),1)
2606 ENDDO
2607C-----------------------------------------------
2608C SUBSET : PART FILLES MESHLESS
2609C-----------------------------------------------
2610 j=m3
2611 DO i=1,npart
2612 IF(mater(i)==4)THEN
2613 j=j+1
2614 mater(i)=j
2615 ENDIF
2616 ENDDO
2617 m4=j
2618 IF (nsubs==1) THEN
2619C #PARTS FILLES meshless
2620 n0=0
2621 DO k=1,npart
2622 IF(mater(k)>m3)THEN
2623 n0=n0+1
2624 ENDIF
2625 ENDDO
2626C PARTS FILLES meshless
2627 CALL write_i_c(n0,1)
2628 DO k=1,npart
2629 IF(mater(k)>m3)
2630 . CALL write_i_c(mater(k)-m3-1,1)
2631 ENDDO
2632 ELSE
2633C----------------
2634C +SIEURS SUBSET
2635C----------------
2636 DO i=1,nsubs-1
2637C #PARTS FILLES meshless
2638 n0=0
2639 DO j=1,subset(i)%NPART
2640 k = subset(i)%PART(j)
2641 IF(mater(k)>m3)THEN
2642 n0=n0+1
2643 ENDIF
2644 ENDDO
2645C PARTS FILLES meshless
2646 CALL write_i_c(n0,1)
2647 DO j=1,subset(i)%NPART
2648 k = subset(i)%PART(j)
2649 IF(mater(k)>m3)
2650 . CALL write_i_c(mater(k)-m3-1,1)
2651 ENDDO
2652 ENDDO
2653C--------------
2654C GLOBAL MODEL
2655C--------------
2656C #PARTS FILLES meshless
2657 n0=0
2658 DO j=1,subset(i)%NPART
2659 k = subset(i)%PART(j)
2660 IF(mater(k)>m3)THEN
2661 n0=n0+1
2662 ENDIF
2663 ENDDO
2664C PARTS FILLES meshless
2665 CALL write_i_c(n0,1)
2666 DO j=1,subset(i)%NPART
2667 k = subset(i)%PART(j)
2668 IF(mater(k)>m3)
2669 . CALL write_i_c(mater(k)-m3-1,1)
2670 ENDDO
2671 ENDIF
2672C--------------
2673 DO i=1,npart
2674 IF(mater(i)<0)mater(i)=-mater(i)
2675 ENDDO
2676C=======================================================================
2677 700 CONTINUE
2678C=======================================================================
2679 CALL close_c
2680C-----------------------------------------------
2681 WRITE (iout,1000) filnam(1:filen)
2682 WRITE (istdo,1100) filnam(1:filen)
2683 1000 FORMAT (/' ANIMATION FILE:',1x,a,' WRITTEN'/
2684 . ' ---------------')
2685 1100 FORMAT (' .. ANIMATION FILE:',1x,a,' WRITTEN')
2686C
2687 RETURN
anioffs
subroutine anioffs(elbuf_tab, iparg, ioff, el2fa, nbf, nbpart, isph3d)
Definition anioffs.F:32
my_real
#define my_real
Definition cppsort.cpp:32
delnumbs
subroutine delnumbs(iparg, ixs, el2fa, nbf, inum, kxsp, isph3d)
Definition delnumbs.F:32
delsub
subroutine delsub(nlevel, elsub, ilevel, offset, nel, el2fa, func)
Definition delsub.F:30
dfuncs
subroutine dfuncs(elbuf_tab, func, ifunc, iparg, ixs, pm, el2fa, nbf, isph3d)
Definition dfuncs.F:33
dmasanis
subroutine dmasanis(elbuf_tab, iparg, ixs, mas, pm, el2fa, nbf, ipart, ipartsp, isph3d)
Definition dmasanis.F:34
eloff
subroutine eloff(ixs, ixq, ixc, ixp, ixt, ixr, ixtg, iparg, iactiv, time, iflag, nn, elbuf_tab, x, temp, mcp, pm, igroups, mcp_off, igrbric, igrquad, igrsh4n, igrsh3n, igrtruss, igrbeam, igrspring, itherm_fe)
Definition eloff.F:43
xyznor16
subroutine xyznor16(ixs, ixs10, ixs20, ixs16, x)
Definition genani1.F:2785
xyz16
subroutine xyz16(ixs, ixs10, ixs20, ixs16, x)
Definition genani1.F:2697
invert
subroutine invert(matrix, inverse, n, errorflag)
Definition hm_read_rbe3.F:1368
ymax
subroutine ymax(idn, fac, npc, pld, stiffmin, stiffmax, stiffini, stiffavg)
Definition law100_upd.F:274
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
fvbag_mod
Definition fvbag_mod.F:44
fvbag_mod::fvdata
type(fvbag_data), dimension(:), allocatable fvdata
Definition fvbag_mod.F:128
fvbag_mod::nfvbag
integer nfvbag
Definition fvbag_mod.F:127
groupdef_mod
Definition groupdef_mod.F:668
inoutfile_mod
Definition inoutfile_mod.F:96
inoutfile_mod::outfile_name
character(len=outfile_char_len) outfile_name
Definition inoutfile_mod.F:111
inoutfile_mod::outfile_name_len
integer outfile_name_len
Definition inoutfile_mod.F:109
message_mod
Definition message_mod.F:1257
names_and_titles_mod
Definition names_and_titles_mod.F:1002
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1008
ani_txt50
subroutine ani_txt50(text, len)
Definition ani_txt.F:61
ani_txt
subroutine ani_txt(text, len)
Definition ani_txt.F:30
anioff0
subroutine anioff0(elbuf_tab, iparg, ioff, el2fa, nbf, sioff, sph2sol)
Definition anioff0.F:32
anioffc
subroutine anioffc(elbuf_tab, iparg, ioff, el2fa, nbf)
Definition anioffc.F:31
aniofff
subroutine aniofff(elbuf_tab, iparg, ioff, el2fa, nbf, ioffx1)
Definition aniofff.F:32
aniskew
subroutine aniskew(elbuf_tab, skew, iparg, x, ixt, ixp, ixr, geo, bufl)
Definition aniskew.F:32
aniskewf
subroutine aniskewf(geo, skew, iparg, ixr, lrbuf)
Definition aniskewf.F:31
delnumb0
subroutine delnumb0(iparg, el2fa, nbf, inum, kxsp)
Definition delnumb0.F:30
delnumbc
subroutine delnumbc(iparg, ixq, ixc, ixtg, el2fa, nbf, inum, nelcut, nbpart, idcmax)
Definition delnumbc.F:33
delnumbf
subroutine delnumbf(iparg, ixt, ixp, ixr, el2fa, nbf, inum, inumx1)
Definition delnumbf.F:33
dfunc0
subroutine dfunc0(elbuf_tab, func, ifunc, iparg, pm, el2fa, nbf, spbuf, ipart, ipartsp)
Definition dfunc0.F:32
dfuncc
subroutine dfuncc(elbuf_tab, bufel, func, ifunc, iparg, ixq, ixc, ixtg, pm, el2fa, nbf)
Definition dfuncc.F:33
dfuncf
subroutine dfuncf(elbuf_tab, func, ifunc, iparg, geo, ixt, ixp, ixr, mass, pm, el2fa, nbf, iadp, nbpart, xfunc1)
Definition dfuncf.F:33
dmasani0
subroutine dmasani0(elbuf_tab, iparg, mas, pm, el2fa, ipart, ipartsp)
Definition dmasani0.F:31
dmasanic
subroutine dmasanic(elbuf_tab, x, d, geo, iparg, ixq, ixc, ixtg, mas, pm, el2fa, nbf)
Definition dmasanic.F:32
dmasanif
subroutine dmasanif(x, d, elbuf_tab, geo, iparg, ixt, ixp, ixr, mas, pm, el2fa, nbf)
Definition dmasanif.F:32
donerby
subroutine donerby(irby, nerby, npby, nerbt)
Definition donerby.F:29
donerwl
subroutine donerwl(irwl, nerwl, nprw)
Definition donerwl.F:29
donesec
subroutine donesec(isect, nesct, nstrf, ixs)
Definition donesec.F:30
donesrg
subroutine donesrg(isrg, nesrg)
Definition donesrg.F:29
dparrby
subroutine dparrby(lpby, npby)
Definition dparrby.F:30
dparrws
subroutine dparrws(nesbw, nstrf, ixc, ixtg, x, nodcut, rwbuf, nprw, ixs)
Definition dparrws.F:33
dparsrg
subroutine dparsrg(nsurg, nnwl, nodcut)
Definition dparsrg.F:30
drbycnt
subroutine drbycnt(nerby, npby)
Definition drbycnt.F:29
dseccnt
subroutine dseccnt(nesct, nerwl, nesbw, nstrf, rwbuf, nprw, nnwl, ixs)
Definition dseccnt.F:31
dsecnor
subroutine dsecnor(x, rwbuf, nprw)
Definition dsecnor.F:32
dsphcnt
subroutine dsphcnt(nesph, nnsph, nesphg, nnsphg)
Definition dsphcnt.F:29
dsphnor
subroutine dsphnor(kxsp, x, spbuf, nnsph)
Definition dsphnor.F:30
dsrgcnt
subroutine dsrgcnt(igrsurf, nsurg, nesrg, nnsrg, nesbw)
Definition dsrgcnt.F:30
dsrgnor
subroutine dsrgnor(igrsurf, bufsf)
Definition dsrgnor.F:31
dxyzsect
subroutine dxyzsect(nstrf, rwbuf, nprw, x, xmin, ymin, zmin, xmax, ymax, zmax, itab)
Definition dxyzsect.F:36
dxyzsph
subroutine dxyzsph(nesph, kxsp, x, spbuf, snnsphg, nnsph)
Definition dxyzsph.F:30
dxyzsrg
subroutine dxyzsrg(nesrg, igrsurf, bufsf)
Definition dxyzsrg.F:31
parsor0
subroutine parsor0(iadd, iparg, mater, el2fa, kxsp, ipartsp)
Definition parsor0.F:31
parsorc
subroutine parsorc(x, d, xnorm, iadd, cdg, bufel, iparg, ixq, ixc, ixtg, invert, el2fa, mater, ipartq, ipartc, iparttg, elbuf_tab)
Definition parsorc.F:36
parsorf
subroutine parsorf(iadd, iparg, ixt, ixp, ixr, mater, el2fa, ipartt, ipartp, ipartr, nfacptx, ixedge)
Definition parsorf.F:33
parsors
subroutine parsors(iadd, iparg, ixs, mater, iparts, el2fa, insph, kxsp, ipartsp, ixs10, ixs20, ixs16, nnsph, isph3d, shft16, shftsph, nnsphg)
Definition parsors.F:35
tensor0
subroutine tensor0(elbuf_tab, iparg, itens, pm, el2fa, nbf, tens, ipart, ipartsp)
Definition tensor0.F:32
tensorc
subroutine tensorc(elbuf_tab, iparg, itens, invert, nelcut, el2fa, nbf, tens, iadp, nbf_l, nbpart, x, ixc, igeo, ixtg)
Definition tensorc.F:34
velvec
subroutine velvec(v, nnwl, nnsrg)
Definition velvec.F:30
xyznor
subroutine xyznor(xnorm)
Definition xyznor.F:31
fretitl2
subroutine fretitl2(titr, iasc, l)
Definition freform.F:799
tensors
subroutine tensors(elbuf_tab, iparg, itens, ixs, pm, el2fa, nbf, tens, x, ipart, ipartsp, isph3d, ipm)
Definition tensors.F:35
write_s_c
void write_s_c(int *w, int *len)
Definition write_routines.c:687
write_i_c
void write_i_c(int *w, int *len)
Definition write_routines.c:645
write_r_c
void write_r_c(float *w, int *len)
Definition write_routines.c:519
close_c
void close_c()
Definition write_routines.c:298
cur_fil_c
void cur_fil_c(int *nf)
Definition write_routines.c:477
write_c_c
void write_c_c(int *w, int *len)
Definition write_routines.c:591
open_c
void open_c(int *ifil, int *len, int *mod)
Definition write_routines.c:180

◆ xyz16()

subroutine xyz16 ( integer, dimension(nixs,*) ixs,
integer, dimension(6,*) ixs10,
integer, dimension(12,*) ixs20,
integer, dimension(8,*) ixs16,
x )

Definition at line 2696 of file genani1.F.

2697 use element_mod , only : nixs
2698C-----------------------------------------------
2699C I m p l i c i t T y p e s
2700C-----------------------------------------------
2701#include "implicit_f.inc"
2702C-----------------------------------------------
2703C C o m m o n B l o c k s
2704C-----------------------------------------------
2705#include "com04_c.inc"
2706C-----------------------------------------------
2707C D u m m y A r g u m e n t s
2708C-----------------------------------------------
2709 my_real
2710 . x(3,*)
2711 INTEGER IXS(NIXS,*),
2712 . IXS10(6,*) ,IXS16(8,*) ,IXS20(12,*)
2713C-----------------------------------------------
2714C L o c a l V a r i a b l e s
2715C-----------------------------------------------
2716 my_real
2717 . xx,yy,zz
2718 REAL R4,R4NP(6*NUMELS16)
2719 INTEGER I, J, K,N1,N2,N3,N4,N5,N6,N7,N8,
2720 . JJ,BUF
2721C-----------------------------------------------
2722 jj = 0
2723 DO j=1,numels16
2724 i = j+numels8+numels10+numels20
2725 n1 = ixs(2,i)
2726 n2 = ixs(3,i)
2727 n3 = ixs(4,i)
2728 n4 = ixs(5,i)
2729 n5 = ixs16(1,j)
2730 n6 = ixs16(2,j)
2731 n7 = ixs16(3,j)
2732 n8 = ixs16(4,j)
2733 IF(n5==0)n5=n1
2734 IF(n6==0)n6=n2
2735 IF(n7==0)n7=n3
2736 IF(n8==0)n8=n4
2737 xx = half *(x(1,n5)+x(1,n6)+x(1,n7)+x(1,n8))
2738 . -fourth*(x(1,n1)+x(1,n2)+x(1,n3)+x(1,n4))
2739 yy = half *(x(2,n5)+x(2,n6)+x(2,n7)+x(2,n8))
2740 . -fourth*(x(2,n1)+x(2,n2)+x(2,n3)+x(2,n4))
2741 zz = half *(x(3,n5)+x(3,n6)+x(3,n7)+x(3,n8))
2742 . -fourth*(x(3,n1)+x(3,n2)+x(3,n3)+x(3,n4))
2743 r4 = xx
2744 CALL write_r_c(r4,1)
2745 r4 = yy
2746 CALL write_r_c(r4,1)
2747 r4 = zz
2748 CALL write_r_c(r4,1)
2749 n1 = ixs(6,i)
2750 n2 = ixs(7,i)
2751 n3 = ixs(8,i)
2752 n4 = ixs(9,i)
2753 n5 = ixs16(5,j)
2754 n6 = ixs16(6,j)
2755 n7 = ixs16(7,j)
2756 n8 = ixs16(8,j)
2757 IF(n5==0)n5=n1
2758 IF(n6==0)n6=n2
2759 IF(n7==0)n7=n3
2760 IF(n8==0)n8=n4
2761 xx = half *(x(1,n5)+x(1,n6)+x(1,n7)+x(1,n8))
2762 . -fourth*(x(1,n1)+x(1,n2)+x(1,n3)+x(1,n4))
2763 yy = half *(x(2,n5)+x(2,n6)+x(2,n7)+x(2,n8))
2764 . -fourth*(x(2,n1)+x(2,n2)+x(2,n3)+x(2,n4))
2765 zz = half *(x(3,n5)+x(3,n6)+x(3,n7)+x(3,n8))
2766 . -fourth*(x(3,n1)+x(3,n2)+x(3,n3)+x(3,n4))
2767 r4 = xx
2768 CALL write_r_c(r4,1)
2769 r4 = yy
2770 CALL write_r_c(r4,1)
2771 r4 = zz
2772 CALL write_r_c(r4,1)
2773 ENDDO
2774C
2775 RETURN

◆ xyznor16()

subroutine xyznor16 ( integer, dimension(nixs,*) ixs,
integer, dimension(6,*) ixs10,
integer, dimension(12,*) ixs20,
integer, dimension(8,*) ixs16,
x )

Definition at line 2784 of file genani1.F.

2785 use element_mod , only : nixs
2786C-----------------------------------------------
2787C I m p l i c i t T y p e s
2788C-----------------------------------------------
2789#include "implicit_f.inc"
2790C-----------------------------------------------
2791C C o m m o n B l o c k s
2792C-----------------------------------------------
2793#include "com04_c.inc"
2794C-----------------------------------------------
2795C D u m m y A r g u m e n t s
2796C-----------------------------------------------
2797 my_real
2798 . x(3,*)
2799 INTEGER IXS(NIXS,*),
2800 . IXS10(6,*) ,IXS16(8,*) ,IXS20(12,*)
2801C-----------------------------------------------
2802C L o c a l V a r i a b l e s
2803C-----------------------------------------------
2804 my_real
2805 . xx,yy,zz
2806 REAL R4
2807 INTEGER I, J, K,N1,N2,N3,N4,N5,N6,N7,N8,I3000,SIZ
2808C-----------------------------------------------
2809 i3000 = 3000
2810 siz = numels16
2811 DO j=1,siz
2812 CALL write_s_c(i3000,1)
2813 CALL write_s_c(i3000,1)
2814 CALL write_s_c(i3000,1)
2815 CALL write_s_c(i3000,1)
2816 CALL write_s_c(i3000,1)
2817 CALL write_s_c(i3000,1)
2818 ENDDO
2819C
2820 RETURN