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

Go to the source code of this file.

Functions/Subroutines

subroutine stat_c_auxf (elbuf_tab, iparg, ipm, igeo, ixc, ixtg, wa, wap0, ipartc, iparttg, ipart_state, stat_indxc, stat_indxtg, sizp0)

Function/Subroutine Documentation

◆ stat_c_auxf()

subroutine stat_c_auxf ( type (elbuf_struct_), dimension(ngroup), target elbuf_tab,
integer, dimension(nparg,*) iparg,
integer, dimension(npropmi,*) ipm,
integer, dimension(npropgi,*) igeo,
integer, dimension(nixc,*) ixc,
integer, dimension(nixtg,*) ixtg,
double precision, dimension(*) wa,
double precision, dimension(*) wap0,
integer, dimension(*) ipartc,
integer, dimension(*) iparttg,
integer, dimension(*) ipart_state,
integer, dimension(*) stat_indxc,
integer, dimension(*) stat_indxtg,
integer sizp0 )

Definition at line 37 of file stat_c_auxf.F.

40C-----------------------------------------------
41C M o d u l e s
42C-----------------------------------------------
43 USE elbufdef_mod
44 USE my_alloc_mod
45 use element_mod , only : nixc,nixtg
46C-----------------------------------------------
47C I m p l i c i t T y p e s
48C-----------------------------------------------
49#include "implicit_f.inc"
50C-----------------------------------------------
51C C o m m o n B l o c k s
52C-----------------------------------------------
53#include "com01_c.inc"
54#include "param_c.inc"
55#include "units_c.inc"
56#include "scr14_c.inc"
57#include "scr16_c.inc"
58#include "task_c.inc"
59C-----------------------------------------------
60C D u m m y A r g u m e n t s
61C-----------------------------------------------
62 INTEGER SIZP0
63 INTEGER IXC(NIXC,*),IXTG(NIXTG,*),
64 . IPARG(NPARG,*),IPM(NPROPMI,*),IGEO(NPROPGI,*),
65 . IPARTC(*), IPARTTG(*), IPART_STATE(*),
66 . STAT_INDXC(*), STAT_INDXTG(*)
67 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP), TARGET :: ELBUF_TAB
68 double precision WA(*),WAP0(*)
69C-----------------------------------------------
70C L o c a l V a r i a b l e s
71C-----------------------------------------------
72 INTEGER I,N,J,K,JJ,LEN, IOFF,
73 . NG, NEL, NFT, ITY, LFT,LLT, MLW, ID, IPRT0,IPRT,IE,
74 . NPG,NPT,NPTR,NPTS,NPTT,NLAY,IR,IS,IT,IPT,IL,
75 . IVAR,NUVAR,MY_NUVAR,NPT_ALL,IGTYP
76 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA
77 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA_P0
78 double precision
79 . THK, EM, EB, H1, H2, H3
80 CHARACTER*100 DELIMIT,LINE
81 TYPE(G_BUFEL_) ,POINTER :: GBUF
82 TYPE(L_BUFEL_) ,POINTER :: LBUF
83 TYPE(BUF_LAY_) ,POINTER :: BUFLY
84 my_real, DIMENSION(:) ,POINTER :: uvar,siga,sigb,sigc
85C-----------------------------------------------
86 DATA delimit(1:60)
87 ./'#---1----|----2----|----3----|----4----|----5----|----6----|'/
88 DATA delimit(61:100)
89 ./'----7----|----8----|----9----|----10---|'/
90C-----------------------------------------------
91C 4-NODE SHELLS
92C-----------------------------------------------
93 CALL my_alloc(ptwa,max(stat_numelc ,stat_numeltg))
94 ALLOCATE(ptwa_p0(0:max(1,stat_numelc_g,stat_numeltg_g)))
95C-----------------------------------------------
96 jj = 0
97 IF (stat_numelc==0) GOTO 200
98C
99 ie=0
100 DO ng=1,ngroup
101 ity = iparg(5,ng)
102 IF (ity == 3) THEN
103 gbuf => elbuf_tab(ng)%GBUF
104 mlw = iparg(1,ng)
105 nel = iparg(2,ng)
106 nft = iparg(3,ng)
107 igtyp = iparg(38,ng)
108 nptr = elbuf_tab(ng)%NPTR
109 npts = elbuf_tab(ng)%NPTS
110 nptt = elbuf_tab(ng)%NPTT
111 nlay = elbuf_tab(ng)%NLAY
112 npg = nptr*npts
113 npt = nlay*nptt
114 lft=1
115 llt=nel
116C
117C pre counting of all NPTT (especially for PID_51)
118C
119 IF (igtyp == 51 .OR. igtyp == 52) THEN
120 npt_all = 0
121 DO il=1,nlay
122 npt_all = npt_all + elbuf_tab(ng)%BUFLY(il)%NPTT
123 ENDDO
124 npt = max(1,npt_all)
125 ENDIF
126c--------------------
127 DO i=lft,llt
128 n = i + nft
129C
130 iprt=ipartc(n)
131 IF (ipart_state(iprt)==0) cycle
132C
133 jj = jj + 1
134 IF (mlw /= 0 .AND. mlw /= 13) THEN
135 wa(jj) = gbuf%OFF(i)
136 ELSE
137 wa(jj) = 0
138 ENDIF
139 jj = jj + 1
140 wa(jj) = iprt
141 jj = jj + 1
142 wa(jj) = ixc(nixc,n)
143 jj = jj + 1
144 wa(jj) = npt
145 jj = jj + 1
146 wa(jj) = npg
147C
148 IF (mlw == 36) THEN ! STA/AUX contains only backstress
149 my_nuvar = 0
150 DO il = 1,nlay
151 nuvar = elbuf_tab(ng)%BUFLY(il)%L_SIGB
152 my_nuvar = max(my_nuvar, nuvar)
153 END DO
154 jj = jj + 1
155 wa(jj) = my_nuvar
156c
157 IF (nuvar > 0) THEN
158 DO is=1,npts
159 DO ir=1,nptr
160 DO il = 1,nlay
161 bufly => elbuf_tab(ng)%BUFLY(il)
162 nuvar = elbuf_tab(ng)%BUFLY(il)%L_SIGB
163 nptt = elbuf_tab(ng)%BUFLY(il)%NPTT
164 DO it=1,nptt
165 sigb => bufly%LBUF(ir,is,it)%SIGB
166 DO ivar=1,nuvar
167 jj = jj + 1
168 wa(jj) = sigb((ivar-1)*nel + i)
169 ENDDO
170 ENDDO
171 ENDDO
172 ENDDO
173 ENDDO
174 ELSE
175 DO ir=1,nptr
176 DO is=1,npts
177 DO il = 1,nlay
178 DO it=1,nptt
179 DO ivar=1,my_nuvar
180 jj = jj + 1
181 wa(jj) = zero
182 ENDDO
183 ENDDO
184 ENDDO
185 ENDDO
186 ENDDO
187 END IF
188C
189 ELSEIF (mlw == 78) THEN ! STA/AUX contains only backstress
190 my_nuvar = elbuf_tab(ng)%BUFLY(1)%NVAR_MAT + 18 ! 3 x 6 for backstress
191 jj = jj + 1
192 wa(jj) = my_nuvar
193c
194 DO is=1,npts
195 DO ir=1,nptr
196 DO il = 1,nlay
197 bufly => elbuf_tab(ng)%BUFLY(il)
198 nuvar = bufly%NVAR_MAT
199 nptt = bufly%NPTT
200 DO it=1,nptt
201 lbuf => bufly%LBUF(ir,is,it)
202 uvar => bufly%MAT(ir,is,it)%VAR
203 siga => lbuf%SIGA
204 sigb => lbuf%SIGB
205 sigc => lbuf%SIGC
206 DO ivar=1,nuvar
207 jj = jj + 1
208 wa(jj) = uvar((ivar-1)*nel + i)
209 ENDDO
210 DO ivar=1,bufly%L_SIGA
211 jj = jj + 1
212 wa(jj) = siga((ivar-1)*nel + i)
213 ENDDO
214 DO ivar=1,bufly%L_SIGB
215 jj = jj + 1
216 wa(jj) = sigb((ivar-1)*nel + i)
217 ENDDO
218 DO ivar=1,bufly%L_SIGC
219 jj = jj + 1
220 wa(jj) = sigc((ivar-1)*nel + i)
221 ENDDO
222 ENDDO
223 ENDDO
224 ENDDO
225 ENDDO ! DO IL = 1,NLAY
226C
227 ELSEIF (mlw == 87) THEN ! STA/AUX contains only backstress
228 bufly => elbuf_tab(ng)%BUFLY(1)
229 my_nuvar = bufly%NVAR_MAT + bufly%L_SIGB
230 jj = jj + 1
231 wa(jj) = my_nuvar
232c
233 DO is=1,npts
234 DO ir=1,nptr
235 DO il = 1,nlay
236 bufly => elbuf_tab(ng)%BUFLY(il)
237 nuvar = bufly%NVAR_MAT
238 nptt = bufly%NPTT
239 DO it=1,nptt
240 lbuf => bufly%LBUF(ir,is,it)
241 uvar => bufly%MAT(ir,is,it)%VAR
242 sigb => lbuf%SIGB
243 DO ivar=1,nuvar
244 jj = jj + 1
245 wa(jj) = uvar((ivar-1)*nel + i)
246 ENDDO
247 DO ivar=1,bufly%L_SIGB
248 jj = jj + 1
249 wa(jj) = sigb((ivar-1)*nel + i)
250 ENDDO
251 ENDDO
252 ENDDO
253 ENDDO
254 ENDDO ! DO IL = 1,NLAY
255c
256 ELSEIF (mlw == 112) THEN ! STA/AUX
257 my_nuvar = 3
258 jj = jj + 1
259 wa(jj) = my_nuvar
260c
261 DO is=1,npts
262 DO ir=1,nptr
263 DO il = 1,nlay
264 nptt = elbuf_tab(ng)%BUFLY(il)%NPTT
265 DO it=1,nptt
266 DO ivar=1,3
267 jj = jj + 1
268 wa(jj) = elbuf_tab(ng)%BUFLY(il)%LBUF(ir,is,it)%PLA(i + ivar*nel)
269 ENDDO
270 ENDDO
271 ENDDO
272 ENDDO
273 ENDDO ! DO IL = 1,NLAY
274c
275 ELSE IF (mlw >= 28 .and. mlw /= 32) THEN
276 my_nuvar = ipm(8,ixc(1,n))
277 jj = jj + 1
278 wa(jj) = my_nuvar
279C
280 IF (nlay > 1) THEN ! PID11
281 DO is=1,npts
282 DO ir=1,nptr
283 DO il = 1,nlay
284 nuvar = elbuf_tab(ng)%BUFLY(il)%NVAR_MAT
285 nptt = elbuf_tab(ng)%BUFLY(il)%NPTT
286 DO it=1,nptt
287 uvar => elbuf_tab(ng)%BUFLY(il)%MAT(ir,is,it)%VAR
288 DO ivar=1,my_nuvar
289 jj = jj + 1
290 wa(jj) = uvar((ivar-1)*nel + i)
291 ENDDO
292 ENDDO
293 ENDDO
294 ENDDO
295 ENDDO ! DO IL = 1,NLAY
296 ELSE ! NLAY == 1 -> PID1
297 nptt = elbuf_tab(ng)%BUFLY(1)%NPTT
298 DO is=1,npts
299 DO ir=1,nptr
300 DO it=1,nptt
301 uvar => elbuf_tab(ng)%BUFLY(1)%MAT(ir,is,it)%VAR
302 DO ivar=1,my_nuvar
303 jj = jj + 1
304 wa(jj) = uvar((ivar-1)*nel + i)
305 ENDDO
306 ENDDO
307 ENDDO
308 ENDDO
309 ENDIF ! NLAY
310 ELSE ! Not User law
311 my_nuvar = 0
312 jj = jj + 1
313 wa(jj) = my_nuvar
314 ENDIF
315c--------------------
316 ie=ie+1
317C end-of-zone pointer in wa
318 ptwa(ie)=jj
319 ENDDO ! DO I=LFT,LLT
320 ENDIF ! IF (ITY == 3)
321 ENDDO ! DO NG=1,NGROUP
322C
323 200 CONTINUE
324C
325 IF (nspmd == 1) THEN
326 ptwa_p0(0)=0
327 DO n=1,stat_numelc
328 ptwa_p0(n)=ptwa(n)
329 ENDDO
330 len=jj
331 DO j=1,len
332 wap0(j)=wa(j)
333 ENDDO
334 ELSE
335C builds the pointers in the global wap0 array
336 CALL spmd_stat_pgather(ptwa,stat_numelc,ptwa_p0,stat_numelc_g)
337 len = 0
338 CALL spmd_rgather9_dp(wa,jj,wap0,sizp0,len)
339 END IF
340C
341 IF (ispmd == 0.AND.len > 0) THEN
342 iprt0=0
343 DO n=1,stat_numelc_g
344C find the nieme elt in the order of an increasing id
345 k=stat_indxc(n)
346C Find the address in WAP0
347 j=ptwa_p0(k-1)
348C
349 ioff = nint(wap0(j + 1))
350 my_nuvar = nint(wap0(j + 6))
351C
352 IF (ioff >= 1 .AND. my_nuvar /= 0) THEN
353 iprt = nint(wap0(j + 2))
354 IF (iprt /= iprt0) THEN
355 IF (izipstrs == 0) THEN
356 WRITE(iugeo,'(A)') delimit
357 WRITE(iugeo,'(A)')'/INISHE/AUX'
358 WRITE(iugeo,'(A)')
359 .'#------------------------ REPEAT --------------------------'
360 WRITE(iugeo,'(A)')
361 . '# SHELLID NPT NPG NVAR'
362 WRITE(iugeo,'(A/A)')
363 .'# THE CONTENT OF THE FOLLOWING CARDS WILL NOT BE DISCLOSED',
364 .'# THEY MUST NOT BE CHANGED.'
365 WRITE(iugeo,'(A)')
366 .'#---------------------- END REPEAT ------------------------'
367 WRITE(iugeo,'(A)') delimit
368 ELSE
369 WRITE(line,'(A)') delimit
370 CALL strs_txt50(line,100)
371 WRITE(line,'(A)')'/INISHE/AUX'
372 CALL strs_txt50(line,100)
373 WRITE(line,'(A)')
374 .'#------------------------ REPEAT --------------------------'
375 CALL strs_txt50(line,100)
376 WRITE(line,'(A)')
377 . '# SHELLID NPT NPG NVAR'
378 CALL strs_txt50(line,100)
379 WRITE(line,'(A)')
380 .'# THE CONTENT OF THE FOLLOWING CARDS WILL NOT BE DISCLOSED'
381 CALL strs_txt50(line,100)
382 WRITE(line,'(A)')
383 .'# THEY MUST NOT BE CHANGED.'
384 CALL strs_txt50(line,100)
385 WRITE(line,'(A)')
386 .'#---------------------- END REPEAT ------------------------'
387 CALL strs_txt50(line,100)
388 WRITE(line,'(A)') delimit
389 CALL strs_txt50(line,100)
390 ENDIF ! IF (IZIPSTRS == 0)
391 iprt0=iprt
392 ENDIF ! IF (IPRT /= IPRT0)
393 id = nint(wap0(j + 3))
394 npt = nint(wap0(j + 4))
395 npg = nint(wap0(j + 5))
396 my_nuvar = nint(wap0(j + 6))
397 j = j + 6
398 IF (izipstrs == 0) THEN
399 WRITE(iugeo,'(4I10)')id,npt,npg,my_nuvar
400 ELSE
401 WRITE(line,'(4I10)')id,npt,npg,my_nuvar
402 CALL strs_txt50(line,100)
403 ENDIF
404 DO jj=1,npt*npg
405 IF (izipstrs == 0) THEN
406 WRITE(iugeo,'(1P5E20.13)')(wap0(j + k),k=1,my_nuvar)
407 ELSE
408 CALL tab_strs_txt50(wap0(1),my_nuvar,j,sizp0,5)
409 ENDIF
410 j=j+my_nuvar
411 ENDDO
412 ENDIF ! IF (IOFF == 1 .AND. MY_NUVAR /= 0)
413 ENDDO ! DO N=1,STAT_NUMELC_G
414 ENDIF ! IF (ISPMD == 0.AND.LEN > 0)
415C-----------------------------------------------
416C 3-NODE SHELLS
417C-----------------------------------------------
418 jj = 0
419 IF (stat_numeltg==0) GOTO 300
420C
421 ie=0
422C
423 DO ng=1,ngroup
424 ity = iparg(5,ng)
425 IF (ity == 7) THEN
426 gbuf => elbuf_tab(ng)%GBUF
427 mlw = iparg(1,ng)
428 nel = iparg(2,ng)
429 nft = iparg(3,ng)
430 igtyp = iparg(38,ng)
431 nptr = elbuf_tab(ng)%NPTR
432 npts = elbuf_tab(ng)%NPTS
433 nptt = elbuf_tab(ng)%NPTT
434 nlay = elbuf_tab(ng)%NLAY
435 npg = nptr*npts
436 npt = nlay*nptt
437 lft=1
438 llt=nel
439C
440C pre counting of all NPTT (especially for PID_51)
441C
442 IF (igtyp == 51 .OR. igtyp == 52) THEN
443 npt_all = 0
444 DO il=1,nlay
445 npt_all = npt_all + elbuf_tab(ng)%BUFLY(il)%NPTT
446 ENDDO
447 npt = max(1,npt_all)
448 ENDIF
449c--------------------
450 DO i=lft,llt
451 n = i + nft
452C
453 iprt=iparttg(n)
454 IF (ipart_state(iprt)==0) cycle
455C
456 jj = jj + 1
457 IF (mlw /= 0 .AND. mlw /= 13) THEN
458 wa(jj) = gbuf%OFF(i)
459 ELSE
460 wa(jj) = zero
461 ENDIF
462 jj = jj + 1
463 wa(jj) = iprt
464 jj = jj + 1
465 wa(jj) = ixtg(nixtg,n)
466 jj = jj + 1
467 wa(jj) = npt
468 jj = jj + 1
469 wa(jj) = npg
470c
471 IF (mlw == 36) THEN ! STA/AUX contains only backstress
472 my_nuvar = 0
473 DO il = 1,nlay
474 nuvar = elbuf_tab(ng)%BUFLY(il)%L_SIGB
475 my_nuvar = max(my_nuvar, nuvar)
476 END DO
477 jj = jj + 1
478 wa(jj) = my_nuvar
479c
480 DO il = 1,nlay
481 bufly => elbuf_tab(ng)%BUFLY(il)
482 nuvar = bufly%L_SIGB
483 nptt = bufly%NPTT
484 IF (nuvar > 0) THEN
485 DO ir=1,nptr
486 DO is=1,npts
487 DO it=1,nptt
488 sigb => bufly%LBUF(ir,is,it)%SIGB
489 DO ivar=1,nuvar
490 jj = jj + 1
491 wa(jj) = sigb((ivar-1)*nel + i)
492 ENDDO
493 ENDDO
494 ENDDO
495 ENDDO
496 ELSE
497 DO ir=1,nptr
498 DO is=1,npts
499 DO it=1,nptt
500 DO ivar=1,my_nuvar
501 jj = jj + 1
502 wa(jj) = zero
503 ENDDO
504 ENDDO
505 ENDDO
506 ENDDO
507 END IF
508 ENDDO ! DO IL = 1,NLAY
509C
510 ELSEIF (mlw == 78) THEN ! STA/AUX contains only backstress
511 my_nuvar = 0
512 DO il = 1,nlay
513 nuvar = elbuf_tab(ng)%BUFLY(il)%L_SIGB
514 my_nuvar = max(my_nuvar, nuvar)
515 END DO
516 my_nuvar = my_nuvar + 18 ! 3 x 6 for backstress
517 jj = jj + 1
518 wa(jj) = my_nuvar
519c
520 DO is=1,npts
521 DO ir=1,nptr
522 DO il = 1,nlay
523 bufly => elbuf_tab(ng)%BUFLY(il)
524 nuvar = bufly%NVAR_MAT
525 nptt = bufly%NPTT
526 DO it=1,nptt
527 lbuf => bufly%LBUF(ir,is,it)
528 uvar => bufly%MAT(ir,is,it)%VAR
529 siga => lbuf%SIGA
530 sigb => lbuf%SIGB
531 sigc => lbuf%SIGC
532 DO ivar=1,nuvar
533 jj = jj + 1
534 wa(jj) = uvar((ivar-1)*nel + i)
535 ENDDO
536 DO ivar=1,bufly%L_SIGA
537 jj = jj + 1
538 wa(jj) = siga((ivar-1)*nel + i)
539 ENDDO
540 DO ivar=1,bufly%L_SIGB
541 jj = jj + 1
542 wa(jj) = sigb((ivar-1)*nel + i)
543 ENDDO
544 DO ivar=1,bufly%L_SIGC
545 jj = jj + 1
546 wa(jj) = sigc((ivar-1)*nel + i)
547 ENDDO
548 ENDDO
549 ENDDO
550 ENDDO
551 ENDDO ! DO IL = 1,NLAY
552C
553 ELSEIF (mlw == 87) THEN ! STA/AUX contains only backstress
554 my_nuvar = elbuf_tab(ng)%BUFLY(1)%NVAR_MAT + 12 ! 2 x 6 for backstress
555 jj = jj + 1
556 wa(jj) = my_nuvar
557c
558 DO is=1,npts
559 DO ir=1,nptr
560 DO il = 1,nlay
561 bufly => elbuf_tab(ng)%BUFLY(il)
562 nuvar = bufly%NVAR_MAT
563 nptt = bufly%NPTT
564 DO it=1,nptt
565 lbuf => bufly%LBUF(ir,is,it)
566 uvar => bufly%MAT(ir,is,it)%VAR
567 sigb => lbuf%SIGB
568 DO ivar=1,nuvar
569 jj = jj + 1
570 wa(jj) = uvar((ivar-1)*nel + i)
571 ENDDO
572 DO ivar=1,bufly%L_SIGB
573 jj = jj + 1
574 wa(jj) = sigb((ivar-1)*nel + i)
575 ENDDO
576 ENDDO
577 ENDDO
578 ENDDO
579 ENDDO ! DO IL = 1,NLAY
580c
581 ELSE IF (mlw >= 28 .and. mlw /= 32) THEN
582 my_nuvar = ipm(8,ixtg(1,n))
583 jj = jj + 1
584 wa(jj) = my_nuvar
585c
586 IF (nlay > 1) THEN ! PID11
587 DO ir=1,npts
588 DO is=1,nptr
589 DO il = 1,nlay
590 nuvar = elbuf_tab(ng)%BUFLY(il)%NVAR_MAT
591 nptt = elbuf_tab(ng)%BUFLY(il)%NPTT
592 DO it=1,nptt
593 uvar => elbuf_tab(ng)%BUFLY(il)%MAT(ir,is,it)%VAR
594 DO ivar=1,my_nuvar
595 jj = jj + 1
596 wa(jj) = uvar((ivar-1)*nel + i)
597 ENDDO
598 ENDDO
599 ENDDO
600 ENDDO
601 ENDDO
602 ELSE ! NLAY ==1 -> PID1
603 nptt = elbuf_tab(ng)%BUFLY(1)%NPTT
604 DO is=1,npts
605 DO ir=1,nptr
606 DO it=1,nptt
607 uvar => elbuf_tab(ng)%BUFLY(1)%MAT(ir,is,it)%VAR
608 DO ivar=1,my_nuvar
609 jj = jj + 1
610 wa(jj) = uvar((ivar-1)*nel + i)
611 ENDDO
612 ENDDO
613 ENDDO
614 ENDDO
615 ENDIF ! NLAY
616 ELSE ! Not User law
617 my_nuvar = 0
618 jj = jj + 1
619 wa(jj) = my_nuvar
620 ENDIF
621c--------------------
622 ie=ie+1
623C end-of-zone pointer
624 ptwa(ie)=jj
625 ENDDO ! DO I=LFT,LLT
626 ENDIF ! IF (ITY == 7) THEN
627 ENDDO ! DO NG=1,NGROUP
628C
629 300 CONTINUE
630C
631 IF (nspmd == 1) THEN
632 len=jj
633 DO j=1,len
634 wap0(j)=wa(j)
635 ENDDO
636 ptwa_p0(0)=0
637 DO n=1,stat_numeltg
638 ptwa_p0(n)=ptwa(n)
639 ENDDO
640 ELSE
641C builds the pointers in the global wap0 array
642 CALL spmd_stat_pgather(ptwa,stat_numeltg,ptwa_p0,stat_numeltg_g)
643 len = 0
644 CALL spmd_rgather9_dp(wa,jj,wap0,sizp0,len)
645 ENDIF
646C
647 IF (ispmd == 0.AND.len > 0) THEN
648C
649 iprt0=0
650 DO n=1,stat_numeltg_g
651C find the nieme elt in the order of an increasing id
652 k=stat_indxtg(n)
653C Find the address in WAP0
654 j=ptwa_p0(k-1)
655C
656 ioff = nint(wap0(j + 1))
657 my_nuvar = nint(wap0(j + 6))
658C
659 IF (ioff >= 1 .AND. my_nuvar /= 0) THEN
660 iprt = nint(wap0(j + 2))
661 IF (iprt /= iprt0) THEN
662 IF (izipstrs == 0) THEN
663 WRITE(iugeo,'(A)') delimit
664 WRITE(iugeo,'(A)')'/INISH3/AUX'
665 WRITE(iugeo,'(A)')
666 .'#------------------------ REPEAT --------------------------'
667 WRITE(iugeo,'(A)')
668 . '# SH3NID NPT NPG NVAR'
669 WRITE(iugeo,'(A/A)')
670 .'# THE CONTENT OF THE FOLLOWING CARDS WILL NOT BE DISCLOSED',
671 .'# THEY MUST NOT BE CHANGED.'
672 WRITE(iugeo,'(A)')
673 .'#---------------------- END REPEAT ------------------------'
674 WRITE(iugeo,'(A)') delimit
675 ELSE
676 WRITE(line,'(A)') delimit
677 CALL strs_txt50(line,100)
678 WRITE(line,'(A)')'/INISH3/AUX'
679 CALL strs_txt50(line,100)
680 WRITE(line,'(A)')
681 .'#------------------------ REPEAT --------------------------'
682 CALL strs_txt50(line,100)
683 WRITE(line,'(A)')
684 . '# SH3NID NPT NPG NVAR'
685 CALL strs_txt50(line,100)
686 WRITE(line,'(A)')
687 .'# THE CONTENT OF THE FOLLOWING CARDS WILL NOT BE DISCLOSED'
688 CALL strs_txt50(line,100)
689 WRITE(line,'(A)')
690 .'# THEY MUST NOT BE CHANGED.'
691 CALL strs_txt50(line,100)
692 WRITE(line,'(A)')
693 .'#---------------------- END REPEAT ------------------------'
694 CALL strs_txt50(line,100)
695 WRITE(line,'(A)') delimit
696 CALL strs_txt50(line,100)
697 ENDIF ! IF (IZIPSTRS == 0)
698 iprt0=iprt
699 ENDIF ! IF (IPRT /= IPRT0)
700 id = nint(wap0(j + 3))
701 npt = nint(wap0(j + 4))
702 npg = nint(wap0(j + 5))
703 my_nuvar = nint(wap0(j + 6))
704 j = j + 6
705 IF (izipstrs == 0) THEN
706 WRITE(iugeo,'(4I10)')id,npt,npg,my_nuvar
707 ELSE
708 WRITE(line,'(4I10)')id,npt,npg,my_nuvar
709 CALL strs_txt50(line,100)
710 ENDIF
711 DO jj=1,npt*npg
712 IF (izipstrs == 0) THEN
713 WRITE(iugeo,'(1P5E20.13)')(wap0(j + k),k=1,my_nuvar)
714 ELSE
715 CALL tab_strs_txt50(wap0(1),my_nuvar,j,sizp0,5)
716 ENDIF
717 j=j+my_nuvar
718 ENDDO
719 ENDIF ! IF (IOFF == 1 .AND. MY_NUVAR /= 0)
720 ENDDO ! DO N=1,STAT_NUMELTG_G
721 ENDIF ! IF (ISPMD == 0.AND.LEN > 0)
722c-----------
723 DEALLOCATE(ptwa)
724 DEALLOCATE(ptwa_p0)
725c-----------
726 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
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