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 36 of file stat_c_auxf.F.

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