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