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

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