OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
spmd_msin_addmass.F File Reference
#include "implicit_f.inc"
#include "com04_c.inc"
#include "param_c.inc"
#include "scr17_c.inc"
#include "remesh_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine spmd_msin_addmass (ixs, ixs10, ixs20, ixs16, ixq, ixc, ixt, ixp, ixr, ixtg, mss, mssx, msq, msc, mst, msp, msr, mstg, ptg, ms, index, itri, geo, sh4tree, sh3tree, partsav, ipmas, iparts, ipartq, ipartc, ipartt, ipartp, ipartr, iparttg, totaddmas, ipart, thk, pm, part_area, addedms, itab, partsav1_pon, ele_area)
subroutine spmd_partsav_pon (ixs, ixs10, ixs20, ixs16, ixq, ixc, ixt, ixp, ixr, ixtg, mss, mssx, msq, msc, mst, msp, msr, mstg, index, itri, geo, partsav1_pon, iparts, ipartq, ipartc, ipartt, ipartp, ipartr, iparttg, ipart)

Function/Subroutine Documentation

◆ spmd_msin_addmass()

subroutine spmd_msin_addmass ( integer, dimension(nixs,*) ixs,
integer, dimension(6,*) ixs10,
integer, dimension(12,*) ixs20,
integer, dimension(8,*) ixs16,
integer, dimension(nixq,*) ixq,
integer, dimension(nixc,*) ixc,
integer, dimension(nixt,*) ixt,
integer, dimension(nixp,*) ixp,
integer, dimension(nixr,*) ixr,
integer, dimension(6,*) ixtg,
mss,
mssx,
msq,
msc,
mst,
msp,
msr,
mstg,
ptg,
ms,
integer, dimension(*) index,
integer, dimension(*) itri,
geo,
integer, dimension(ksh4tree,*) sh4tree,
integer, dimension(ksh3tree,*) sh3tree,
partsav,
type (admas_), dimension(nodmas) ipmas,
integer, dimension(*) iparts,
integer, dimension(*) ipartq,
integer, dimension(*) ipartc,
integer, dimension(*) ipartt,
integer, dimension(*) ipartp,
integer, dimension(*) ipartr,
integer, dimension(*) iparttg,
totaddmas,
integer, dimension(lipart1,*) ipart,
thk,
pm,
part_area,
addedms,
integer, dimension(*) itab,
partsav1_pon,
ele_area )

Definition at line 30 of file spmd_msin_addmass.F.

41C-----------------------------------------------
42C M o d u l e s
43C-----------------------------------------------
44 USE optiondef_mod
45 use element_mod , only : nixs,nixq,nixc,nixt,nixp,nixr
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 "com04_c.inc"
54#include "param_c.inc"
55#include "scr17_c.inc"
56#include "remesh_c.inc"
57C-----------------------------------------------
58C D u m m y A r g u m e n t s
59C-----------------------------------------------
60 INTEGER IXS(NIXS,*),IXS10(6,*),IXS20(12,*),IXS16(8,*),
61 . IXQ(NIXQ,*),IXC(NIXC,*),IXT(NIXT,*),IXP(NIXP,*),IXR(NIXR,*),
62 . IXTG(6,*),INDEX(*), ITRI(*),SH4TREE(KSH4TREE,*),
63 . SH3TREE(KSH3TREE,*),IPARTS(*),IPARTQ(*),IPARTC(*),
64 . IPARTT(*),IPARTP(*),IPARTR(*),IPARTTG(*),
65 . IPART(LIPART1,*),ITAB(*)
66C REAL
67 my_real
68 . mss(8,*),mssx(12,*),msq(*),msc(*),mst(*),msp(*),msr(3,*),
69 . mstg(*),ptg(3,*),ms(*),geo(npropg,*),
70 . partsav(20,*),totaddmas,part_area(*),thk(*),
71 . addedms(*),pm(npropm,*),partsav1_pon(npart),ele_area(*)
72C
73 INTEGER IDEB
74 TYPE (ADMAS_) , DIMENSION(NODMAS) :: IPMAS
75C-----------------------------------------------
76C L o c a l V a r i a b l e s
77C-----------------------------------------------
78 INTEGER I, J, K, N, II, IGTYP, WORK(70000),IP,KAD,IGM,IPM,NMAS,
79 . FLAG
80C
81 my_real
82 . mass,kmass,area_el
83C-----------------------------------------------
84C
85! PARTSAV1_PON(1:NPART)=ZERO
86C
87 DO i = 1, numels
88 itri(i) = ixs(11,i)
89 ENDDO
90C
91 CALL my_orders(0,work,itri,index,numels8,1)
92
93 ideb=numels8+1
94 CALL my_orders(0,work,itri(ideb),index(ideb),numels10,1)
95
96 DO j=1,numels10
97 index(ideb+j-1) = index(ideb+j-1)+numels8
98 ENDDO
99
100 ideb = ideb + numels10
101 CALL my_orders(0,work,itri(ideb),index(ideb),numels20,1)
102 DO j = 1, numels20
103 index(ideb+j-1) = index(ideb+j-1)+numels8+numels10
104 ENDDO
105
106 ideb = ideb + numels20
107 CALL my_orders(0,work,itri(ideb),index(ideb),numels16,1)
108 DO j = 1, numels16
109 index(ideb+j-1) = index(ideb+j-1)+numels8+numels10+numels20
110 ENDDO
111C
112 DO igm=1,nodmas
113 nmas = ipmas(igm)%NPART
114 DO ii = 1,nmas
115 ipm = ipmas(igm)%PARTID(ii)
116C NUMELS
117 DO j=1,numels
118 i = index(j)
119 ip = iparts(i)
120 IF(ip == ipm)THEN
121 DO k=1,8
122 n = ixs(k+1,i)
123 kmass = mss(k,i) / max(em20,partsav1_pon(ip))
124 mass = kmass * ipmas(igm)%PART(ii)%RPMAS
125 ms(n) = ms(n) + mass
126 totaddmas = totaddmas + mass
127 ENDDO
128 ENDIF
129 ENDDO
130C NUMELS10
131 IF(numels10>0) THEN
132 DO j=1,numels10
133 i = index(numels8+j)
134 ip = iparts(i)
135 IF(ip == ipm)THEN
136 DO k=1,6
137 n = ixs10(k,i-numels8)
138 kmass = mssx(k,i) / max(em20,partsav1_pon(ip))
139 mass = kmass * ipmas(igm)%PART(ii)%RPMAS
140 IF(n/=0)THEN
141 ms(n) = ms(n) + mass
142 totaddmas = totaddmas + mass
143 END IF
144 ENDDO
145 ENDIF
146 ENDDO
147 ENDIF
148C NUMELS20
149 IF(numels20>0)THEN
150 DO j=1,numels20
151 i = index(numels8+numels10+j)
152 ip = iparts(i)
153 IF(ip == ipm)THEN
154 DO k=1,12
155 n = ixs20(k,i-numels8-numels10)
156 kmass = mssx(k,i) / max(em20,partsav1_pon(ip))
157 mass = kmass * ipmas(igm)%PART(ii)%RPMAS
158 IF(n/=0)THEN
159 ms(n) = ms(n) + mass
160 totaddmas = totaddmas + mass
161 ENDIF
162 ENDDO
163 ENDIF
164 ENDDO
165 ENDIF
166C NUMELS20
167 IF(numels16>0)THEN
168 DO j=1,numels16
169 i = index(numels8+numels10+numels20+j)
170 ip = iparts(i)
171 IF(ip == ipm)THEN
172 DO k=1,8
173 n = ixs16(k,i-numels8-numels10-numels20)
174 kmass = mssx(k,i) / max(em20,partsav1_pon(ip))
175 mass = kmass * ipmas(igm)%PART(ii)%RPMAS
176 IF(n/=0)THEN
177 ms(n) = ms(n) + mass
178 totaddmas = totaddmas + mass
179 ENDIF
180 ENDDO
181 ENDIF
182 ENDDO
183 ENDIF
184 ENDDO
185 ENDDO
186C NUMELQ
187 DO i = 1, numelq
188 itri(i) = ixq(7,i)
189 ENDDO
190 CALL my_orders(0,work,itri,index,numelq,1)
191C
192 DO igm=1,nodmas
193 nmas = ipmas(igm)%NPART
194 DO ii = 1,nmas
195 ipm = ipmas(igm)%PARTID(ii)
196 DO j=1,numelq
197 i = index(j)
198 ip = ipartq(i)
199 IF(ip == ipm)THEN
200 kmass = msq(i) / max(em20,partsav1_pon(ip))
201 mass = kmass * ipmas(igm)%PART(ii)%RPMAS
202 DO k=1,4
203 n = ixq(k+1,i)
204 ms(n) = ms(n) + mass
205 totaddmas = totaddmas + mass
206 ENDDO
207 ENDIF
208 ENDDO
209 ENDDO
210 ENDDO
211C NUMELC
212
213
214C=======================================================================
215C Compute area of part
216 DO i = 1, numeltg
217 itri(i) = ixtg(6,i)
218 ENDDO
219 CALL my_orders(0,work,itri,index,numeltg,1)
220C P/ON computation of PART_AREA
221 DO j=1,numeltg
222 i = index(j)
223 ip = iparttg(i)
224 area_el = ele_area(i+numelc)
225 part_area(ip) = part_area(ip) + area_el
226 ENDDO
227 DO i = 1, numelc
228 itri(i) = ixc(7,i)
229 ENDDO
230 CALL my_orders(0,work,itri,index,numelc,1)
231C P/ON computation of PART_AREA
232 DO j=1,numelc
233 i = index(j)
234 ip = ipartc(i)
235 area_el = ele_area(i)
236 part_area(ip) = part_area(ip) + area_el
237 ENDDO
238C=======================================================================
239C
240 DO igm=1,nodmas
241 nmas = ipmas(igm)%NPART
242 flag = ipmas(igm)%WEIGHT_FLAG
243 DO ii = 1,nmas
244 ipm = ipmas(igm)%PARTID(ii)
245 IF(nadmesh==0)THEN
246 DO j=1,numelc
247 i = index(j)
248 ip = ipartc(i)
249 IF(ip == ipm)THEN
250 IF(flag == 0)THEN
251 kmass = msc(i) / max(em20,partsav1_pon(ip))
252 ELSE IF(flag == 1)THEN
253 area_el = ele_area(i)*fourth
254 kmass = area_el / max(em20,part_area(ip))
255 END IF
256 mass = kmass * ipmas(igm)%PART(ii)%RPMAS
257 DO k=1,4
258 n = ixc(k+1,i)
259 ms(n) = ms(n) + mass
260 totaddmas = totaddmas + mass
261 ENDDO
262 ENDIF
263 ENDDO
264
265 ELSE
266 IF(istatcnd==0)THEN
267 DO j=1,numelc
268 i = index(j)
269 IF(sh4tree(3,i) >= 0)THEN
270 ip = ipartc(i)
271 IF(ip == ipm)THEN
272 IF(flag == 0)THEN
273 kmass = msc(i) / max(em20,partsav1_pon(ip))
274 ELSE IF(flag == 1)THEN
275 area_el = ele_area(i)*fourth
276 kmass = area_el / max(em20,part_area(ip))
277 END IF
278 mass = kmass * ipmas(igm)%PART(ii)%RPMAS
279 DO k=1,4
280 n = ixc(k+1,i)
281 ms(n) = ms(n) + mass
282 totaddmas = totaddmas + mass
283 ENDDO
284 ENDIF
285 ENDIF
286 ENDDO
287 ELSE
288 DO j=1,numelc
289 i = index(j)
290 IF(sh4tree(3,i) == 0 .OR. sh4tree(3,i) == -1)THEN
291 ip = ipartc(i)
292 IF(ip == ipm)THEN
293 IF(flag == 0)THEN
294 kmass = msc(i) / max(em20,partsav1_pon(ip))
295 ELSE IF(flag == 1)THEN
296 area_el = ele_area(i)*fourth
297 kmass = area_el / max(em20,part_area(ip))
298 END IF
299 mass = kmass * ipmas(igm)%PART(ii)%RPMAS
300 DO k=1,4
301 n = ixc(k+1,i)
302 ms(n) = ms(n) + mass
303 totaddmas = totaddmas + mass
304 ENDDO
305 ENDIF
306 ENDIF
307 ENDDO
308 ENDIF
309 ENDIF
310 ENDDO
311 ENDDO
312C NUMELT
313 DO i = 1, numelt
314 itri(i) = ixt(5,i)
315 ENDDO
316 CALL my_orders(0,work,itri,index,numelt,1)
317C
318 DO igm=1,nodmas
319 nmas = ipmas(igm)%NPART
320 DO ii = 1,nmas
321 ipm = ipmas(igm)%PARTID(ii)
322 DO j=1,numelt
323 i = index(j)
324 ip = ipartt(i)
325 IF(ip == ipm)THEN
326 kmass = mst(i) / max(em20,partsav1_pon(ip))
327 mass = kmass * ipmas(igm)%PART(ii)%RPMAS
328 DO k=1,2
329 n = ixt(k+1,i)
330 ms(n) = ms(n) + mass
331 totaddmas = totaddmas + mass
332 ENDDO
333 ENDIF
334 ENDDO
335 ENDDO
336 ENDDO
337C NUMELP
338 DO i = 1, numelp
339 itri(i) = ixp(6,i)
340 ENDDO
341 CALL my_orders(0,work,itri,index,numelp,1)
342C
343 DO igm=1,nodmas
344 nmas = ipmas(igm)%NPART
345 DO ii = 1,nmas
346 ipm = ipmas(igm)%PARTID(ii)
347 DO j=1,numelp
348 i = index(j)
349 ip = ipartp(i)
350 IF(ip == ipm)THEN
351 kmass = msp(i) / max(em20,partsav1_pon(ip))
352 mass = kmass * ipmas(igm)%PART(ii)%RPMAS
353 n = ixp(2,i)
354 ms(n) = ms(n) + mass
355 totaddmas = totaddmas + mass
356 n = ixp(3,i)
357 ms(n) = ms(n) + mass
358 totaddmas = totaddmas + mass
359 ENDIF
360 ENDDO
361 ENDDO
362 ENDDO
363C NUMELR
364 DO i = 1, numelr
365 itri(i) = ixr(6,i)
366 ENDDO
367 CALL my_orders(0,work,itri,index,numelr,1)
368C
369 DO igm=1,nodmas
370 nmas = ipmas(igm)%NPART
371 DO ii = 1,nmas
372 ipm = ipmas(igm)%PARTID(ii)
373 DO j=1,numelr
374 i = index(j)
375 ip = ipartr(i)
376 IF(ip == ipm)THEN
377 DO k=1,2
378 n = ixr(k+1,i)
379 kmass = msr(k,i) / max(em20,partsav1_pon(ip))
380 mass = kmass * ipmas(igm)%PART(ii)%RPMAS
381 ms(n) = ms(n) + mass
382 totaddmas = totaddmas + mass
383 ENDDO
384 igtyp = nint(geo(12,ixr(1,i)))
385 IF(igtyp==12) THEN
386 n = ixr(4,i)
387 kmass = msr(3,i) / max(em20,partsav1_pon(ip))
388 mass = kmass * ipmas(igm)%PART(ii)%RPMAS
389 ms(n) = ms(n) + mass
390 totaddmas = totaddmas + mass
391 ENDIF
392 ENDIF
393 ENDDO
394 ENDDO
395 ENDDO
396C NUMELTG
397 DO i = 1, numeltg
398 itri(i) = ixtg(6,i)
399 ENDDO
400 CALL my_orders(0,work,itri,index,numeltg,1)
401
402 DO igm=1,nodmas
403 nmas = ipmas(igm)%NPART
404 DO ii = 1,nmas
405 ipm = ipmas(igm)%PARTID(ii)
406 IF(nadmesh==0)THEN
407 DO j=1,numeltg
408 i = index(j)
409 ip = iparttg(i)
410 IF(ip == ipm)THEN
411!---
412 IF(flag == 0)THEN
413 kmass = mstg(i) / max(em20,partsav1_pon(ip))
414 ELSEIF(flag == 1)THEN
415 area_el = ele_area(i+numelc)
416 kmass = area_el / max(em20,part_area(ip))
417 ENDIF
418 mass = kmass * ipmas(igm)%PART(ii)%RPMAS
419!---
420 DO k=1,3
421 n = ixtg(k+1,i)
422 ms(n) = ms(n) + mass*ptg(k,i)
423 totaddmas = totaddmas + mass*ptg(k,i)
424 ENDDO
425 ENDIF
426 ENDDO
427 ELSE
428 IF(istatcnd==0)THEN
429 DO j=1,numeltg
430 i = index(j)
431 IF(sh3tree(3,i) >= 0)THEN
432 ip = iparttg(i)
433 IF(ip == ipm)THEN
434!---
435 IF(flag == 0)THEN
436 kmass = mstg(i) / max(em20,partsav1_pon(ip))
437 ELSEIF(flag == 1)THEN
438 area_el = ele_area(i+numelc)
439 kmass = area_el / max(em20,part_area(ip))
440 ENDIF
441 mass = kmass * ipmas(igm)%PART(ii)%RPMAS
442!---
443 DO k=1,3
444 n = ixtg(k+1,i)
445 ms(n) = ms(n) + mass*ptg(k,i)
446 totaddmas = totaddmas + mass*ptg(k,i)
447 ENDDO
448 ENDIF
449 ENDIF
450 ENDDO
451 ELSE
452 DO j=1,numeltg
453 i = index(j)
454 IF(sh3tree(3,i) == 0 .OR. sh3tree(3,i) == -1)THEN
455 ip = iparttg(i)
456 IF(ip == ipm)THEN
457!---
458 IF(flag == 0)THEN
459 kmass = mstg(i) / max(em20,partsav1_pon(ip))
460 ELSEIF(flag == 1)THEN
461 area_el = ele_area(i+numelc)
462 kmass = area_el / max(em20,part_area(ip))
463 ENDIF
464 mass = kmass * ipmas(igm)%PART(ii)%RPMAS
465!---
466 DO k=1,3
467 n = ixtg(k+1,i)
468 ms(n) = ms(n) + mass*ptg(k,i)
469 totaddmas = totaddmas + mass*ptg(k,i)
470 ENDDO
471 ENDIF
472 ENDIF
473 ENDDO
474 ENDIF
475 ENDIF
476 ENDDO
477 ENDDO
478C---
479 DO i=1,npart
480 IF(addedms(i) > zero) THEN
481 partsav(1,i) = partsav(1,i) + addedms(i)
482 partsav1_pon(i) = partsav1_pon(i) + addedms(i)
483 ENDIF
484 END DO
485C---
486 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
max
#define max(a, b)
Definition macros.h:21
my_orders
void my_orders(int *mode, int *iwork, int *data, int *index, int *n, int *irecl)
Definition my_orders.c:82
optiondef_mod
Definition optiondef_mod.F:90

◆ spmd_partsav_pon()

subroutine spmd_partsav_pon ( integer, dimension(nixs,*) ixs,
integer, dimension(6,*) ixs10,
integer, dimension(12,*) ixs20,
integer, dimension(8,*) ixs16,
integer, dimension(nixq,*) ixq,
integer, dimension(nixc,*) ixc,
integer, dimension(nixt,*) ixt,
integer, dimension(nixp,*) ixp,
integer, dimension(nixr,*) ixr,
integer, dimension(6,*) ixtg,
mss,
mssx,
msq,
msc,
mst,
msp,
msr,
mstg,
integer, dimension(*) index,
integer, dimension(*) itri,
geo,
partsav1_pon,
integer, dimension(*) iparts,
integer, dimension(*) ipartq,
integer, dimension(*) ipartc,
integer, dimension(*) ipartt,
integer, dimension(*) ipartp,
integer, dimension(*) ipartr,
integer, dimension(*) iparttg,
integer, dimension(lipart1,*) ipart )

Definition at line 495 of file spmd_msin_addmass.F.

503 use element_mod , only : nixs,nixq,nixc,nixt,nixp,nixr
504C-----------------------------------------------
505C I m p l i c i t T y p e s
506C-----------------------------------------------
507#include "implicit_f.inc"
508C-----------------------------------------------
509C C o m m o n B l o c k s
510C-----------------------------------------------
511#include "com04_c.inc"
512#include "param_c.inc"
513#include "scr17_c.inc"
514C-----------------------------------------------
515C D u m m y A r g u m e n t s
516C-----------------------------------------------
517 INTEGER IXS(NIXS,*),IXS10(6,*),IXS20(12,*),IXS16(8,*),
518 . IXQ(NIXQ,*),IXC(NIXC,*),IXT(NIXT,*),IXP(NIXP,*),IXR(NIXR,*),
519 . IXTG(6,*),INDEX(*), ITRI(*),
520 . IPARTS(*),IPARTQ(*),IPARTC(*),
521 . IPARTT(*),IPARTP(*),IPARTR(*),IPARTTG(*),
522 . IPART(LIPART1,*)
523C REAL
524 my_real
525 . mss(8,*),mssx(12,*),msq(*),msc(*),mst(*),msp(*),msr(3,*),
526 . mstg(*),geo(npropg,*),partsav1_pon(npart)
527C
528 INTEGER IDEB
529C-----------------------------------------------
530C L o c a l V a r i a b l e s
531C-----------------------------------------------
532 INTEGER I, J, K, N, II, IGTYP, WORK(70000),IP,KAD,IGM,IPM,NMAS,
533 . FLAG
534C-----------------------------------------------
535C
536 partsav1_pon(1:npart)=zero
537C
538 DO i = 1, numels
539 itri(i) = ixs(11,i)
540 ENDDO
541C
542 CALL my_orders(0,work,itri,index,numels8,1)
543
544 ideb=numels8+1
545 CALL my_orders(0,work,itri(ideb),index(ideb),numels10,1)
546
547 DO j=1,numels10
548 index(ideb+j-1) = index(ideb+j-1)+numels8
549 ENDDO
550
551 ideb = ideb + numels10
552 CALL my_orders(0,work,itri(ideb),index(ideb),numels20,1)
553 DO j = 1, numels20
554 index(ideb+j-1) = index(ideb+j-1)+numels8+numels10
555 ENDDO
556
557 ideb = ideb + numels20
558 CALL my_orders(0,work,itri(ideb),index(ideb),numels16,1)
559 DO j = 1, numels16
560 index(ideb+j-1) = index(ideb+j-1)+numels8+numels10+numels20
561 ENDDO
562C
563 DO j=1,numels
564 i = index(j)
565 ip = iparts(i)
566 DO k=1,8
567 partsav1_pon(ip)=partsav1_pon(ip)+mss(k,i)
568 ENDDO
569 ENDDO
570
571C NUMELS10
572 IF(numels10>0) THEN
573 DO j=1,numels10
574 i = index(numels8+j)
575 ip = iparts(i)
576 DO k=1,6
577 partsav1_pon(ip)=partsav1_pon(ip)+mssx(k,i)
578 ENDDO
579 ENDDO
580 ENDIF
581C NUMELS20
582 IF(numels20>0)THEN
583 DO j=1,numels20
584 i = index(numels8+numels10+j)
585 ip = iparts(i)
586 DO k=1,12
587 partsav1_pon(ip)=partsav1_pon(ip)+mssx(k,i)
588 ENDDO
589 ENDDO
590 ENDIF
591C NUMELS16
592 IF(numels16>0)THEN
593 DO j=1,numels16
594 i = index(numels8+numels10+numels20+j)
595 ip = iparts(i)
596 DO k=1,8
597 partsav1_pon(ip)=partsav1_pon(ip)+mssx(k,i)
598 ENDDO
599 ENDDO
600 ENDIF
601
602C NUMELQ
603 DO i = 1, numelq
604 itri(i) = ixq(7,i)
605 ENDDO
606 CALL my_orders(0,work,itri,index,numelq,1)
607C
608 DO j=1,numelq
609 i = index(j)
610 ip = ipartq(i)
611 partsav1_pon(ip)=partsav1_pon(ip)+ four * msq(i)
612 ENDDO
613
614C NUMELC
615 DO i = 1, numelc
616 itri(i) = ixc(7,i)
617 ENDDO
618 CALL my_orders(0,work,itri,index,numelc,1)
619C
620 DO j=1,numelc
621 i=index(j)
622 ip=ipartc(i)
623 partsav1_pon(ip)=partsav1_pon(ip)+ four * msc(i)
624 ENDDO
625
626C NUMELT
627 DO i = 1, numelt
628 itri(i) = ixt(5,i)
629 ENDDO
630 CALL my_orders(0,work,itri,index,numelt,1)
631C
632 DO j=1,numelt
633 i=index(j)
634 ip=ipartt(i)
635 partsav1_pon(ip)=partsav1_pon(ip)+ two * mst(i)
636 ENDDO
637
638C NUMELP
639 DO i = 1, numelp
640 itri(i) = ixp(6,i)
641 ENDDO
642 CALL my_orders(0,work,itri,index,numelp,1)
643C
644 DO j=1,numelp
645 i=index(j)
646 ip=ipartp(i)
647 partsav1_pon(ip)=partsav1_pon(ip)+ two * msp(i)
648 ENDDO
649
650C NUMELR
651 DO i = 1, numelr
652 itri(i) = ixr(6,i)
653 ENDDO
654 CALL my_orders(0,work,itri,index,numelr,1)
655C
656 DO j=1,numelr
657 i=index(j)
658 ip=ipartr(i)
659 igtyp = nint(geo(12,ixr(1,i)))
660 IF(igtyp==12) THEN
661 k=3
662 ELSE
663 k=2
664 ENDIF
665 DO ii=1,k
666 partsav1_pon(ip)=partsav1_pon(ip)+msr(ii,i)
667 ENDDO
668 ENDDO
669
670C NUMELTG
671 DO i = 1, numeltg
672 itri(i) = ixtg(6,i)
673 ENDDO
674 CALL my_orders(0,work,itri,index,numeltg,1)
675C
676 DO j=1,numeltg
677 i=index(j)
678 ip=iparttg(i)
679 partsav1_pon(ip)=partsav1_pon(ip)+mstg(i)
680 ENDDO
681C---
682 RETURN