OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
stat_s_straf.F File Reference
#include "implicit_f.inc"
#include "com01_c.inc"
#include "param_c.inc"
#include "units_c.inc"
#include "task_c.inc"
#include "scr14_c.inc"
#include "scr16_c.inc"
#include "vect01_c.inc"
#include "scr17_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine stat_s_straf (elbuf_tab, iparg, ipm, igeo, ixs, wa, wap0, iparts, ipart_state, stat_indxs, x, iglob, ipart, sizp0)

Function/Subroutine Documentation

◆ stat_s_straf()

subroutine stat_s_straf ( type (elbuf_struct_), dimension(ngroup), target elbuf_tab,
integer, dimension(nparg,*) iparg,
integer, dimension(npropmi,*) ipm,
integer, dimension(npropgi,*) igeo,
integer, dimension(nixs,*) ixs,
double precision, dimension(*) wa,
double precision, dimension(*) wap0,
integer, dimension(*) iparts,
integer, dimension(*) ipart_state,
integer, dimension(*) stat_indxs,
x,
integer iglob,
integer, dimension(lipart1,*) ipart,
integer sizp0 )

Definition at line 39 of file stat_s_straf.F.

42C-----------------------------------------------
43C M o d u l e s
44C-----------------------------------------------
45 USE initbuf_mod
46 USE elbufdef_mod
47 USE my_alloc_mod
48C-----------------------------------------------
49C I m p l i c i t T y p e s
50C-----------------------------------------------
51#include "implicit_f.inc"
52C-----------------------------------------------
53C C o m m o n B l o c k s
54C-----------------------------------------------
55#include "com01_c.inc"
56#include "param_c.inc"
57#include "units_c.inc"
58#include "task_c.inc"
59#include "scr14_c.inc"
60#include "scr16_c.inc"
61#include "vect01_c.inc"
62#include "scr17_c.inc"
63C-----------------------------------------------
64C D u m m y A r g u m e n t s
65C-----------------------------------------------
66 INTEGER SIZLOC,SIZP0,IGLOB
67 INTEGER IXS(NIXS,*),
68 . IPARG(NPARG,*),IPM(NPROPMI,*),IGEO(NPROPGI,*),
69 . IPARTS(*), IPART_STATE(*), STAT_INDXS(*),IPART(LIPART1,*)
70 my_real
71 . x(3,*)
72 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP), TARGET :: ELBUF_TAB
73 double precision WA(*),WAP0(*)
74C-----------------------------------------------
75C L o c a l V a r i a b l e s
76C-----------------------------------------------
77 INTEGER I,N,J,K,II,JJ,LEN,NLAY,NPTR,NPTS,NPTT,
78 . ISOLNOD,ISTRAIN,NG, NEL, MLW, ID, IPRT0, IPRT,IE,
79 . NPG,IPG,IPT,IL,IR,IS,IT,IPID,PID,IOFF,KK(8)
80 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA
81 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA_P0
82 my_real
83 . gama(6),watmp(6)
84 CHARACTER*100 DELIMIT,LINE
85 DATA delimit(1:60)
86 ./'#---1----|----2----|----3----|----4----|----5----|----6----|'/
87 DATA delimit(61:100)
88 ./'----7----|----8----|----9----|----10---|'/
89C----
90 TYPE(L_BUFEL_) ,POINTER :: LBUF
91 TYPE(G_BUFEL_) ,POINTER :: GBUF
92C-----------------------------------------------
93C 8 NODES BRICK
94C======================================================================|
95 CALL my_alloc(ptwa,stat_numels)
96 ALLOCATE(ptwa_p0(0:max(1,stat_numels_g)))
97C-----------------------------------------------
98 jj = 0
99 IF(stat_numels==0) GOTO 200
100
101 ie=0
102 DO ng=1,ngroup
103 ity =iparg(5,ng)
104 isolnod = iparg(28,ng)
105 mlw =iparg(1,ng)
106 nel =iparg(2,ng)
107 nft =iparg(3,ng)
108 iad =iparg(4,ng)
109c JHBE = IPARG(23,NG)
110 istrain = iparg(44,ng)
111 lft = 1
112 llt = nel
113 iprt=iparts(lft+nft)
114 pid = ipart(2,iprt)
115 jhbe = igeo(10,pid)
116!
117 DO i=1,8 ! length max of GBUF%G_STRA = 8
118 kk(i) = nel*(i-1)
119 ENDDO
120!
121 IF (ity == 1) THEN
122 CALL initbuf(iparg ,ng ,
123 2 mlw ,nel ,nft ,iad ,ity ,
124 3 npt ,jale ,ismstr ,jeul ,jtur ,
125 4 jthe ,jlag ,jmult ,jhbe ,jivf ,
126 5 nvaux ,jpor ,jcvt ,jclose ,jplasol ,
127 6 irep ,iint ,igtyp ,israt ,isrot ,
128 7 icsen ,isorth ,isorthg ,ifailure,jsms )
129 iprt=iparts(lft+nft)
130 pid = ipart(2,iprt)
131C JHBE = IGEO(10,PID)
132 gbuf => elbuf_tab(ng)%GBUF
133 lbuf => elbuf_tab(ng)%BUFLY(1)%LBUF(1,1,1)
134 nlay = elbuf_tab(ng)%NLAY
135 nptr = elbuf_tab(ng)%NPTR
136 npts = elbuf_tab(ng)%NPTS
137 nptt = elbuf_tab(ng)%NPTT
138 npt = nptr * npts * nptt * nlay
139c
140 IF (jcvt==1.AND.isorth/=0) jcvt=2
141c
142
143 IF (isolnod == 16) THEN
144 DO i=lft,llt
145 n = i + nft
146 ii = (i-1)*6
147 iprt=iparts(n)
148 IF(ipart_state(iprt)==0)cycle
149 wa(jj+ 1)= gbuf%VOL(i)
150 wa(jj+ 2)= iprt
151 wa(jj+ 3)= ixs(nixs,n)
152 wa(jj+ 4)= nlay
153 wa(jj+ 5)= nptr
154 wa(jj+ 6)= npts
155 wa(jj+ 7)= nptt
156 wa(jj+ 8)= isolnod
157 wa(jj+ 9)= jhbe
158 wa(jj+10)= igtyp
159 wa(jj+11) = gbuf%OFF(i)
160 jj = jj + 11
161 IF (iglob == 1)THEN
162 IF(jcvt==2)THEN
163 gama(1)=gbuf%GAMA(kk(1)+i)
164 gama(2)=gbuf%GAMA(kk(2)+i)
165 gama(3)=gbuf%GAMA(kk(3)+i)
166 gama(4)=gbuf%GAMA(kk(4)+i)
167 gama(5)=gbuf%GAMA(kk(5)+i)
168 gama(6)=gbuf%GAMA(kk(6)+i)
169 ELSE
170 gama(1)=one
171 gama(2)=zero
172 gama(3)=zero
173 gama(4)=zero
174 gama(5)=one
175 gama(6)=zero
176 END IF
177 ENDIF
178c---
179 is = 1
180 DO it=1,nptt
181 DO ir=1,nptr
182 DO il=1,nlay
183 lbuf => elbuf_tab(ng)%BUFLY(il)%LBUF(ir,is,it)
184 watmp(1) = lbuf%STRA(kk(1)+i)
185 watmp(2) = lbuf%STRA(kk(2)+i)
186 watmp(3) = lbuf%STRA(kk(3)+i)
187 watmp(4) = lbuf%STRA(kk(4)+i)
188 watmp(5) = lbuf%STRA(kk(5)+i)
189 watmp(6) = lbuf%STRA(kk(6)+i)
190 IF (iglob == 1)
191 . CALL srota6(
192 1 x, ixs(1,n),jcvt, watmp,
193 2 gama, jhbe, igtyp, isorth)
194 wa(jj + 1) = watmp(1)
195 wa(jj + 2) = watmp(2)
196 wa(jj + 3) = watmp(3)
197 wa(jj + 4) = watmp(4)
198 wa(jj + 5) = watmp(5)
199 wa(jj + 6) = watmp(6)
200 jj = jj + 6
201 ENDDO
202 ENDDO
203 ENDDO
204 ie=ie+1
205C pointeur de fin de zone dans WA
206 ptwa(ie)=jj
207 ENDDO
208 ELSEIF (isolnod == 20) THEN
209 DO i=lft,llt
210 n = i + nft
211 ii = (i-1)*6
212 iprt=iparts(n)
213 IF(ipart_state(iprt)==0)cycle
214 wa(jj+ 1)= gbuf%VOL(i)
215 wa(jj+ 2)= iprt
216 wa(jj+ 3)= ixs(nixs,n)
217 wa(jj+ 4)= nlay
218 wa(jj+ 5)= nptr
219 wa(jj+ 6)= npts
220 wa(jj+ 7)= nptt
221 wa(jj+ 8)= isolnod
222 wa(jj+ 9)= jhbe
223 wa(jj+10)= igtyp
224 wa(jj+11) = gbuf%OFF(i)
225 jj = jj + 11
226 IF (iglob == 1)THEN
227 IF(jcvt==2)THEN
228 gama(1)=gbuf%GAMA(kk(1)+i)
229 gama(2)=gbuf%GAMA(kk(2)+i)
230 gama(3)=gbuf%GAMA(kk(3)+i)
231 gama(4)=gbuf%GAMA(kk(4)+i)
232 gama(5)=gbuf%GAMA(kk(5)+i)
233 gama(6)=gbuf%GAMA(kk(6)+i)
234 ELSE
235 gama(1)=one
236 gama(2)=zero
237 gama(3)=zero
238 gama(4)=zero
239 gama(5)=one
240 gama(6)=zero
241 END IF
242 ENDIF
243c---
244 il = 1
245 DO it=1,nptt
246 DO is=1,npts
247 DO ir=1,nptr
248 lbuf => elbuf_tab(ng)%BUFLY(il)%LBUF(ir,is,it)
249 watmp(1) = lbuf%STRA(kk(1)+i)
250 watmp(2) = lbuf%STRA(kk(2)+i)
251 watmp(3) = lbuf%STRA(kk(3)+i)
252 watmp(4) = lbuf%STRA(kk(4)+i)
253 watmp(5) = lbuf%STRA(kk(5)+i)
254 watmp(6) = lbuf%STRA(kk(6)+i)
255 IF (iglob == 1)
256 . CALL srota6(
257 1 x, ixs(1,n),jcvt, watmp,
258 2 gama, jhbe, igtyp, isorth)
259 wa(jj + 1) = watmp(1)
260 wa(jj + 2) = watmp(2)
261 wa(jj + 3) = watmp(3)
262 wa(jj + 4) = watmp(4)
263 wa(jj + 5) = watmp(5)
264 wa(jj + 6) = watmp(6)
265 jj = jj + 6
266 ENDDO
267 ENDDO
268 ENDDO
269 ie=ie+1
270C pointeur de fin de zone dans WA
271 ptwa(ie)=jj
272 ENDDO
273
274 ELSEIF (igtyp == 22) THEN
275 DO i=lft,llt
276 n = i + nft
277 ii = (i-1)*6
278 iprt=iparts(n)
279 IF(ipart_state(iprt)==0)cycle
280 wa(jj+ 1)= gbuf%VOL(i)
281 wa(jj+ 2)= iprt
282 wa(jj+ 3)= ixs(nixs,n)
283 wa(jj+ 4)= nlay
284 wa(jj+ 5)= nptr
285 wa(jj+ 6)= npts
286 wa(jj+ 7)= nptt
287 wa(jj+ 8)= isolnod
288 wa(jj+ 9)= jhbe
289 wa(jj+10)= igtyp
290 wa(jj+11) = gbuf%OFF(i)
291 jj = jj + 11
292 IF (iglob == 1)THEN
293 IF(jcvt==2)THEN
294 gama(1)=gbuf%GAMA(kk(1)+i)
295 gama(2)=gbuf%GAMA(kk(2)+i)
296 gama(3)=gbuf%GAMA(kk(3)+i)
297 gama(4)=gbuf%GAMA(kk(4)+i)
298 gama(5)=gbuf%GAMA(kk(5)+i)
299 gama(6)=gbuf%GAMA(kk(6)+i)
300 ELSE
301 gama(1)=one
302 gama(2)=zero
303 gama(3)=zero
304 gama(4)=zero
305 gama(5)=one
306 gama(6)=zero
307 END IF
308 ENDIF
309c---
310 DO ir=1,nptr
311 DO is=1,npts
312 DO it=1,nptt
313 DO il=1,nlay
314 lbuf => elbuf_tab(ng)%BUFLY(il)%LBUF(ir,is,it)
315 watmp(1) = lbuf%STRA(kk(1)+i)
316 watmp(2) = lbuf%STRA(kk(2)+i)
317 watmp(3) = lbuf%STRA(kk(3)+i)
318 watmp(4) = lbuf%STRA(kk(4)+i)
319 watmp(5) = lbuf%STRA(kk(5)+i)
320 watmp(6) = lbuf%STRA(kk(6)+i)
321 IF (iglob == 1)
322 . CALL srota6(
323 1 x, ixs(1,n),jcvt, watmp,
324 2 gama, jhbe, igtyp, isorth)
325 wa(jj + 1) = watmp(1)
326 wa(jj + 2) = watmp(2)
327 wa(jj + 3) = watmp(3)
328 wa(jj + 4) = watmp(4)
329 wa(jj + 5) = watmp(5)
330 wa(jj + 6) = watmp(6)
331 jj = jj + 6
332 ENDDO
333 ENDDO
334 ENDDO
335 ENDDO
336 ie=ie+1
337C pointeur de fin de zone dans WA
338 ptwa(ie)=jj
339 ENDDO
340 ELSEIF (igtyp == 43) THEN
341 DO i=lft,llt
342 n = i + nft
343 ii = (i-1)*3
344 iprt = iparts(n)
345 IF (ipart_state(iprt)==0) cycle
346 wa(jj+ 1)= gbuf%VOL(i)
347 wa(jj+ 2)= iprt
348 wa(jj+ 3)= ixs(nixs,n)
349 wa(jj+ 4)= nlay
350 wa(jj+ 5)= nptr
351 wa(jj+ 6)= npts
352 wa(jj+ 7)= nptt
353 wa(jj+ 8)= isolnod
354 wa(jj+ 9)= jhbe
355 wa(jj+10)= igtyp
356 wa(jj+11) = gbuf%OFF(i)
357 jj = jj + 11
358 gama(1)=one
359 gama(2)=zero
360 gama(3)=zero
361 gama(4)=zero
362 gama(5)=one
363 gama(6)=zero
364c---
365 DO ir=1,nptr
366 lbuf => elbuf_tab(ng)%BUFLY(1)%LBUF(ir,1,1)
367 watmp(1) = zero
368 watmp(2) = zero
369 watmp(3) = lbuf%EPE(kk(1)+i)
370 watmp(4) = zero
371 watmp(5) = lbuf%EPE(kk(2)+i)
372 watmp(6) = lbuf%EPE(kk(3)+i)
373 IF(iglob==1)CALL srota6(
374 1 x, ixs(1,n),jcvt, watmp,
375 2 gama, jhbe, igtyp, isorth)
376 wa(jj + 1) = watmp(1)
377 wa(jj + 2) = watmp(2)
378 wa(jj + 3) = watmp(3)
379 wa(jj + 4) = watmp(4)
380 wa(jj + 5) = watmp(5)
381 wa(jj + 6) = watmp(6)
382 jj = jj + 6
383 ENDDO
384 ie=ie+1
385C pointeur de fin de zone dans WA
386 ptwa(ie)=jj
387 ENDDO
388 ELSEIF (istrain == 0) THEN
389 DO i=lft,llt
390 n = i + nft
391 ii = (i-1)*6
392 iprt=iparts(n)
393 IF(ipart_state(iprt)==0)cycle
394 wa(jj+ 1)= gbuf%VOL(i)
395 wa(jj+ 2)= iprt
396 wa(jj+ 3)= ixs(nixs,n)
397 wa(jj+ 4)= nlay
398 wa(jj+ 5)= nptr
399 wa(jj+ 6)= npts
400 wa(jj+ 7)= nptt
401 wa(jj+ 8)= isolnod
402 wa(jj+ 9)= jhbe
403 wa(jj+10)= igtyp
404 wa(jj+11) = gbuf%OFF(i)
405 jj = jj + 11
406 DO ipt=1,npt
407 wa(jj + 1 ) = zero
408 wa(jj + 2 ) = zero
409 wa(jj + 3 ) = zero
410 wa(jj + 4 ) = zero
411 wa(jj + 5 ) = zero
412 wa(jj + 6 ) = zero
413 jj = jj + 6
414 ENDDO
415 ie=ie+1
416C pointeur de fin de zone dans WA
417 ptwa(ie)=jj
418 ENDDO
419c
420 ELSEIF (igtyp == 20 .OR. igtyp == 21) THEN
421c
422 DO i=lft,llt
423 n = i + nft
424 ii = (i-1)*6
425 iprt=iparts(n)
426 IF(ipart_state(iprt)==0)cycle
427 wa(jj+ 1)= gbuf%VOL(i)
428 wa(jj+ 2)= iprt
429 wa(jj+ 3)= ixs(nixs,n)
430 wa(jj+ 4)= nlay
431 wa(jj+ 5)= nptr
432 wa(jj+ 6)= npts
433 wa(jj+ 7)= nptt
434 wa(jj+ 8)= isolnod
435 wa(jj+ 9)= jhbe
436 wa(jj+10)= igtyp
437 wa(jj+11) = gbuf%OFF(i)
438 jj = jj + 11
439 IF (iglob == 1)THEN
440 IF(jcvt==2)THEN
441 gama(1)=gbuf%GAMA(kk(1)+i)
442 gama(2)=gbuf%GAMA(kk(2)+i)
443 gama(3)=gbuf%GAMA(kk(3)+i)
444 gama(4)=gbuf%GAMA(kk(4)+i)
445 gama(5)=gbuf%GAMA(kk(5)+i)
446 gama(6)=gbuf%GAMA(kk(6)+i)
447 ELSE
448 gama(1)=one
449 gama(2)=zero
450 gama(3)=zero
451 gama(4)=zero
452 gama(5)=one
453 gama(6)=zero
454 END IF
455 ENDIF
456c---
457 DO il=1,nlay
458 DO ir=1,nptr
459 DO is=1,npts
460 DO it=1,nptt
461 lbuf => elbuf_tab(ng)%BUFLY(il)%LBUF(ir,is,it)
462 watmp(1) = lbuf%STRA(kk(1)+i)
463 watmp(2) = lbuf%STRA(kk(2)+i)
464 watmp(3) = lbuf%STRA(kk(3)+i)
465 watmp(4) = lbuf%STRA(kk(4)+i)
466 watmp(5) = lbuf%STRA(kk(5)+i)
467 watmp(6) = lbuf%STRA(kk(6)+i)
468 IF (iglob == 1)
469 . CALL srota6(
470 1 x, ixs(1,n),jcvt, watmp,
471 2 gama, jhbe, igtyp, isorth)
472 wa(jj + 1) = watmp(1)
473 wa(jj + 2) = watmp(2)
474 wa(jj + 3) = watmp(3)
475 wa(jj + 4) = watmp(4)
476 wa(jj + 5) = watmp(5)
477 wa(jj + 6) = watmp(6)
478 jj = jj + 6
479 ENDDO
480 ENDDO
481 ENDDO
482 ENDDO
483 ie=ie+1
484C pointeur de fin de zone dans WA
485 ptwa(ie)=jj
486 ENDDO
487c
488c ELSEIF (ISOLNOD == 8 .AND. (JHBE == 14 .OR. JHBE == 17) .OR.
489c . (ISOLNOD == 6 .OR. ISOLNOD == 8) .AND. JHBE == 15.OR.
490c . (ISOLNOD == 4 .AND. ISROT == 1 )) THEN
491c
492 ELSEIF (jhbe == 12 .OR. jhbe == 14 .OR. jhbe == 17) THEN
493 DO i=lft,llt
494 n = i + nft
495 ii = (i-1)*6
496 iprt=iparts(n)
497 IF(ipart_state(iprt)==0)cycle
498 wa(jj+ 1)= gbuf%VOL(i)
499 wa(jj+ 2)= iprt
500 wa(jj+ 3)= ixs(nixs,n)
501 wa(jj+ 4)= nlay
502 wa(jj+ 5)= nptr
503 wa(jj+ 6)= npts
504 wa(jj+ 7)= nptt
505 wa(jj+ 8)= isolnod
506 wa(jj+ 9)= jhbe
507 wa(jj+10)= igtyp
508 wa(jj+11) = gbuf%OFF(i)
509 IF (jhbe==17.AND.iint==2) wa(jj+ 9)= 18
510 jj = jj + 11
511 IF (iglob == 1)THEN
512 IF(jcvt==2)THEN
513 gama(1)=gbuf%GAMA(kk(1)+i)
514 gama(2)=gbuf%GAMA(kk(2)+i)
515 gama(3)=gbuf%GAMA(kk(3)+i)
516 gama(4)=gbuf%GAMA(kk(4)+i)
517 gama(5)=gbuf%GAMA(kk(5)+i)
518 gama(6)=gbuf%GAMA(kk(6)+i)
519 ELSE
520 gama(1)=one
521 gama(2)=zero
522 gama(3)=zero
523 gama(4)=zero
524 gama(5)=one
525 gama(6)=zero
526 END IF
527 ENDIF
528
529 DO il=1,nlay
530 DO it=1,nptt
531 DO is=1,npts
532 DO ir=1,nptr
533 lbuf => elbuf_tab(ng)%BUFLY(il)%LBUF(ir,is,it)
534 watmp(1) = lbuf%STRA(kk(1)+i)
535 watmp(2) = lbuf%STRA(kk(2)+i)
536 watmp(3) = lbuf%STRA(kk(3)+i)
537 watmp(4) = lbuf%STRA(kk(4)+i)
538 watmp(5) = lbuf%STRA(kk(5)+i)
539 watmp(6) = lbuf%STRA(kk(6)+i)
540 IF (iglob == 1)
541 . CALL srota6(
542 1 x, ixs(1,n),jcvt, watmp,
543 2 gama, jhbe, igtyp, isorth)
544 wa(jj + 1) = watmp(1)
545 wa(jj + 2) = watmp(2)
546 wa(jj + 3) = watmp(3)
547 wa(jj + 4) = watmp(4)
548 wa(jj + 5) = watmp(5)
549 wa(jj + 6) = watmp(6)
550 jj = jj + 6
551 ENDDO
552 ENDDO
553 ENDDO
554 ENDDO
555 ie=ie+1
556c pointeur de fin de zone dans WA
557 ptwa(ie)=jj
558 ENDDO
559c
560 ELSE
561c
562 DO i=lft,llt
563 n = i + nft
564 ii = (i-1)*6
565 iprt=iparts(n)
566 IF(ipart_state(iprt)==0)cycle
567 wa(jj+ 1)= gbuf%VOL(i)
568 wa(jj+ 2)= iprt
569 wa(jj+ 3)= ixs(nixs,n)
570 wa(jj+ 4)= nlay
571 wa(jj+ 5)= nptr
572 wa(jj+ 6)= npts
573 wa(jj+ 7)= nptt
574 wa(jj+ 8)= isolnod
575 wa(jj+ 9)= jhbe
576 wa(jj+10)= igtyp
577 wa(jj+11) = gbuf%OFF(i)
578 IF (jhbe==1.AND.iint==3) wa(jj+ 9)= 5
579 jj = jj + 11
580 IF (iglob == 1)THEN
581 IF(jcvt==2)THEN
582 gama(1)=gbuf%GAMA(kk(1)+i)
583 gama(2)=gbuf%GAMA(kk(2)+i)
584 gama(3)=gbuf%GAMA(kk(3)+i)
585 gama(4)=gbuf%GAMA(kk(4)+i)
586 gama(5)=gbuf%GAMA(kk(5)+i)
587 gama(6)=gbuf%GAMA(kk(6)+i)
588 ELSE
589 gama(1)=one
590 gama(2)=zero
591 gama(3)=zero
592 gama(4)=zero
593 gama(5)=one
594 gama(6)=zero
595 END IF
596 ENDIF
597c---
598 DO il=1,nlay
599 DO ir=1,nptr
600 DO is=1,npts
601 DO it=1,nptt
602 lbuf => elbuf_tab(ng)%BUFLY(il)%LBUF(ir,is,it)
603 watmp(1) = lbuf%STRA(kk(1)+i)
604 watmp(2) = lbuf%STRA(kk(2)+i)
605 watmp(3) = lbuf%STRA(kk(3)+i)
606 watmp(4) = lbuf%STRA(kk(4)+i)
607 watmp(5) = lbuf%STRA(kk(5)+i)
608 watmp(6) = lbuf%STRA(kk(6)+i)
609 IF (iglob == 1)
610 . CALL srota6(
611 1 x, ixs(1,n),jcvt, watmp,
612 2 gama, jhbe, igtyp, isorth)
613 wa(jj + 1) = watmp(1)
614 wa(jj + 2) = watmp(2)
615 wa(jj + 3) = watmp(3)
616 wa(jj + 4) = watmp(4)
617 wa(jj + 5) = watmp(5)
618 wa(jj + 6) = watmp(6)
619 jj = jj + 6
620 ENDDO
621 ENDDO
622 ENDDO
623 ENDDO
624 ie=ie+1
625C pointeur de fin de zone dans WA
626 ptwa(ie)=jj
627 ENDDO
628 ENDIF ! ISOLNOD, JHBE
629C
630 ENDIF ! ITY == 1
631 ENDDO ! NG=1,NGROUP
632 200 CONTINUE
633c-----------------------------------------------------------
634 IF(nspmd == 1)THEN
635C recopies inutiles pour simplification du code.
636 ptwa_p0(0)=0
637 DO n=1,stat_numels
638 ptwa_p0(n)=ptwa(n)
639 END DO
640 len=jj
641 DO j=1,len
642 wap0(j)=wa(j)
643 END DO
644 ELSE
645C construit les pointeurs dans le tableau global WAP0
646 CALL spmd_stat_pgather(ptwa,stat_numels,ptwa_p0,stat_numels_g)
647 len = 0
648 CALL spmd_rgather9_dp(wa,jj,wap0,sizp0,len)
649 END IF
650c-----------------------------------------------------------
651 IF(ispmd == 0.AND.len>0) THEN
652
653 iprt0=0
654 DO n=1,stat_numels_g
655
656C retrouve le nieme elt dans l'ordre d'id croissant
657 k=stat_indxs(n)
658C retrouve l'adresse dans WAP0
659 j=ptwa_p0(k-1)
660 ioff = nint(wap0(j + 11))
661 iprt = nint(wap0(j + 2))
662 IF (ioff >= 1) THEN
663 IF(iprt /= iprt0)THEN
664 IF (izipstrs == 0) THEN
665 WRITE(iugeo,'(A)') delimit
666 IF(iglob == 1)THEN
667 WRITE(iugeo,'(A)')'/INIBRI/STRA_FGLO'
668 ELSE
669 WRITE(iugeo,'(A)')'/INIBRI/STRA_F'
670 ENDIF
671 WRITE(iugeo,'(A)')
672 . '#------------------------ REPEAT -------------------------'
673 WRITE(iugeo,'(A)')
674 . '# BRICKID NPT ISOLNOD ISOLID'
675 WRITE(iugeo,'(A/A/A)')
676 . '# IF(NPT /= 0) REPEAT K=1,NPT ',
677 . '# E1, E2, E3',
678 . '# E12, E23, E31'
679 WRITE(iugeo,'(A)')
680 . '#------------------------ REPEAT -------------------------'
681 WRITE(iugeo,'(A)') delimit
682 ELSE
683 WRITE(line,'(A)') delimit
684 CALL strs_txt50(line,100)
685 IF(iglob == 1)THEN
686 WRITE(line,'(a)')'/inibri/stra_fglo'
687 CALL STRS_TXT50(LINE,100)
688 ELSE
689 WRITE(LINE,'(a)')'/inibri/stra_f'
690 CALL STRS_TXT50(LINE,100)
691 ENDIF
692 WRITE(LINE,'(a)')
693 . '#------------------------ REPEAT -------------------------'
694 CALL strs_txt50(line,100)
695 WRITE(line,'(A)')
696 . '# BRICKID NPT ISOLNOD ISOLID'
697 CALL strs_txt50(line,100)
698 WRITE(line,'(A)')
699 . '# IF(NPT /= 0) REPEAT K=1,NPT '
700 CALL strs_txt50(line,100)
701 WRITE(line,'(A)')'# E1, E2, E3'
702 CALL strs_txt50(line,100)
703 WRITE(line,'(A)')'# E12, E23, E31'
704 CALL strs_txt50(line,100)
705 WRITE(line,'(A)')
706 . '#------------------------ REPEAT -------------------------'
707 CALL strs_txt50(line,100)
708 WRITE(line,'(A)') delimit
709 CALL strs_txt50(line,100)
710 END IF
711 iprt0=iprt
712 END IF
713 id = nint(wap0(j + 3))
714 nlay = nint(wap0(j + 4))
715 nptr = nint(wap0(j + 5))
716 npts = nint(wap0(j + 6))
717 nptt = nint(wap0(j + 7))
718 isolnod = nint(wap0(j + 8))
719 jhbe = nint(wap0(j + 9))
720 igtyp = nint(wap0(j +10))
721 npt = nlay * nptr * npts * nptt
722c
723 j = j + 11
724c------------------------------------------------
725 IF (isolnod == 16) THEN
726 IF (izipstrs == 0) THEN
727 WRITE(iugeo,'(8I10)') id,npt,isolnod,jhbe,nptr,npts,nptt,nlay
728 ELSE
729 WRITE(line,'(8I10)') id,npt,isolnod,jhbe,nptr,npts,nptt,nlay
730 CALL strs_txt50(line,100)
731 ENDIF
732 DO ipt = 1, npt
733 IF (izipstrs == 0) THEN
734 WRITE(iugeo,'(1P3E20.13)')(wap0(j + k),k=1,6)
735 ELSE
736 CALL tab_strs_txt50(wap0(1),6,j,sizp0,3)
737 ENDIF
738 j = j + 6
739 ENDDO
740c
741 ELSEIF (igtyp == 20 .OR. igtyp == 21 .OR. igtyp == 22) THEN
742 IF (izipstrs == 0) THEN
743 WRITE(iugeo,'(7I10)') id,npt,isolnod,jhbe,nptr,npts,nlay
744 ELSE
745 WRITE(line,'(7I10)') id,npt,isolnod,jhbe,nptr,npts,nlay
746 CALL strs_txt50(line,100)
747 ENDIF
748 DO ipt = 1, npt
749 IF (izipstrs == 0) THEN
750 WRITE(iugeo,'(1P3E20.13)')(wap0(j + k),k=1,6)
751 ELSE
752 CALL tab_strs_txt50(wap0(1),6,j,sizp0,3)
753 ENDIF
754 j = j + 6
755 ENDDO
756c
757 ELSEIF ( ((isolnod == 8 .OR. npt == 1) .AND.
758 . jhbe /= 14 .AND. jhbe /= 15) .OR.
759 . (isolnod == 4 .AND. npt == 1) )THEN
760 IF (izipstrs == 0) THEN
761 WRITE(iugeo,'(4I10)') id,npt,isolnod,jhbe
762 WRITE(iugeo,'(1P3E20.13)')(wap0(j + k),k=1,6*npt)
763 ELSE
764 WRITE(line,'(4I10)') id,npt,isolnod,jhbe
765 CALL strs_txt50(line,100)
766 CALL tab_strs_txt50(wap0(1),6*npt,j,sizp0,3)
767 ENDIF
768 j = j + 6
769C
770 ELSEIF((isolnod == 8 .AND. jhbe == 14) .OR.
771 . (isolnod == 4 .AND. npt == 4 ) .OR.
772 . (isolnod == 10) .OR.
773 . (isolnod == 20) .OR.
774 . ((isolnod == 6.OR.isolnod == 8).AND.jhbe == 15).OR.
775 . ((isolnod == 8) .AND. jhbe == 17) .OR.
776 . ((isolnod == 8) .AND. jhbe == 18)) THEN
777 IF (izipstrs == 0) THEN
778 WRITE(iugeo,'(8I10)')id,npt,isolnod,jhbe,
779 . nptr,npts,nptt,nlay
780 ELSE
781 WRITE(line,'(8I10)')id,npt,isolnod,jhbe,
782 . nptr,npts,nptt,nlay
783 CALL strs_txt50(line,100)
784 ENDIF
785c---
786 DO ipt = 1, npt
787 IF (izipstrs == 0) THEN
788 WRITE(iugeo,'(1p3e20.13)')(WAP0(J + K),K=1,6)
789 ELSE
790 CALL TAB_STRS_TXT50(WAP0(1),6,J,SIZP0,3)
791 ENDIF
792 J = J + 6
793 ENDDO
794 ENDIF
795 ENDIF ! IF (IOFF == 1)
796c---
797 ENDDO
798 ENDIF
799c-----------
800 DEALLOCATE(PTWA)
801 DEALLOCATE(PTWA_P0)
802 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
max
#define max(a, b)
Definition macros.h:21
id
initmumps id
Definition multiplerhs_example.m:4
initbuf_mod
Definition initbuf.F:160
initbuf_mod::initbuf
subroutine initbuf(iparg, ng, mtn, llt, nft, iad, ity, npt, jale, ismstr, jeul, jtur, jthe, jlag, jmult, jhbe, jivf, mid, jpor, jcvt, jclose, jpla, irep, iint, igtyp, israt, isrot, icsen, isorth, isorthg, ifailure, jsms)
Definition initbuf.F:261
spmd_rgather9_dp
subroutine spmd_rgather9_dp(v, len, vp0, lenp0, iad)
Definition spmd_outp.F:1015
spmd_stat_pgather
subroutine spmd_stat_pgather(ptv, ptlen, ptv_p0, ptlen_p0)
Definition spmd_stat.F:53
strs_txt50
subroutine strs_txt50(text, length)
Definition sta_txt.F:87
tab_strs_txt50
subroutine tab_strs_txt50(wap0, cpt, j, sizp0, nbpline)
Definition sta_txt.F:127
srota6
subroutine srota6(x, ixs, kcvt, tens, gama)
Definition srota6.F:32