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 40 of file stat_s_strsf.F.

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