OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
stat_s_strsf.F File Reference
#include "implicit_f.inc"
#include "com01_c.inc"
#include "param_c.inc"
#include "units_c.inc"
#include "scr14_c.inc"
#include "task_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_strsf (elbuf_tab, iparg, ipm, igeo, ixs, wa, wap0, iparts, ipart_state, stat_indxs, x, iglob, ipart, sizp0)

Function/Subroutine Documentation

◆ stat_s_strsf()

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