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

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

◆ xyznor16()

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

Definition at line 2780 of file genani1.F.

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