1 : C DYNE34 SOURCE CHAT 05/01/12 23:17:29 5004
2 : SUBROUTINE DYNE34(IPOIN1,IPOIN2,NUMEL1,NUMEL2,XP,YP,XPP,YPP,
3 : & XPALB,IPALB,XPTB,NLIAB,NPLB,I,NPOI,ID1,IP1,IND,
4 : & XBARY,YBARY)
5 : IMPLICIT INTEGER(I-N)
6 : IMPLICIT REAL*8(A-H,O-Z)
7 : *--------------------------------------------------------------------*
8 : * *
9 : * Op{rateur DYNE : algorithme de Fu - de Vogelaere *
10 : * ________________________________________________ *
11 : * *
12 : * calcule les coordonn{es du barycentre form{ par les points *
13 : * IPOIN1, IPOIN2, P, PP, NUMEL1 et NUMEL2. *
14 : * *
15 : * Param}tres: *
16 : * *
17 : * e IPOIN1 point du profil mobile *
18 : * e IPOIN2 point du profil mobile *
19 : * e NUMEL1 {l{ment du profil fixe *
20 : * e NUMEL2 {l{ment du profil fixe *
21 : * e I num{ro de la liaison trait{e *
22 : * e XP,YP coordonn{es du point P d'intersection *
23 : * e XPP,YPP coordonn{es du point PP d'intersection *
24 : * e NLIAB nombre total de liaisons *
25 : * s XBARY coordonn{e suivant X *
26 : * s YBARY coordonn{e suivant Y *
27 : * *
28 : * Auteur, date de cr{ation: *
29 : * *
30 : * Lionel VIVAN, le 1 f{vrier 1991. *
31 : * *
32 : *--------------------------------------------------------------------*
33 : *
34 : INTEGER IPALB(NLIAB,*)
35 : REAL*8 XPTB(NPLB,4,*),XPALB(NLIAB,*)
36 : PARAMETER ( ZERO = 0.D0 )
37 : *
38 : ITYP = IPALB(I,1)
39 : IDIM = IPALB(I,3)
40 : NOMBN1 = IPALB(I,4)
41 : NOMBN2 = IPALB(I,5)
42 : ID2 = ID1 + IDIM
43 : ID3 = ID1 + 2*IDIM
44 : ID4 = ID1 + 3*IDIM
45 : ID6 = ID1 + 5*IDIM
46 : ID7 = ID6 + IDIM*NOMBN1
47 : *
48 : XBARY = XP + XPP
49 : YBARY = YP + YPP
50 : ICAS = 0
51 : IF (IPOIN1.EQ.IPOIN2 ) THEN
52 : NBPOIN = 1
53 : ELSE IF (IPOIN1.GT.IPOIN2 ) THEN
54 : ICAS = 1
55 : NBPOIN = 2
56 : I2 = IPOIN1
57 : 2 CONTINUE
58 : I2 = I2 - 1
59 : IF (I2.EQ.0) I2 = NOMBN2
60 : IF (I2.EQ.IPOIN2) GOTO 4
61 : NBPOIN = NBPOIN + 1
62 : GOTO 2
63 : 4 CONTINUE
64 : ELSE
65 : ICAS = 2
66 : NBPOIN = 2
67 : I6 = IPOIN2
68 : 6 CONTINUE
69 : I6 = I6 + 1
70 : IF (I6.EQ.(NOMBN2+1)) I6 = 1
71 : IF (I6.EQ.IPOIN1) GOTO 8
72 : NBPOIN = NBPOIN + 1
73 : GOTO 6
74 : 8 CONTINUE
75 : ENDIF
76 : IF (ICAS.EQ.1) THEN
77 : IPT1 = IPOIN1
78 : ELSE
79 : IPT1 = IPOIN2
80 : ENDIF
81 : DO 10 IP = 1,NBPOIN
82 : IF (IPT1.EQ.(NOMBN2+1)) IPT1 = 1
83 : IF (IPT1.EQ.0) IPT1 = NOMBN2
84 : IPT2 = ID7 + IDIM*(IPT1-1)
85 : XP1 = ZERO
86 : YP1 = ZERO
87 : DO 12 ID = 1,IDIM
88 : XX1 = XPTB(NPOI,IND,ID) + XPALB(I,IPT2+ID)
89 : & - XPALB(I,ID2+ID)
90 : XP1 = XP1 + ( XX1 * XPALB(I,ID3+ID) )
91 : YP1 = YP1 + ( XX1 * XPALB(I,ID4+ID) )
92 : 12 CONTINUE
93 : * end do
94 : XBARY = XBARY + XP1
95 : YBARY = YBARY + YP1
96 : IF (ICAS.EQ.1) THEN
97 : IPT1 = IPT1 - 1
98 : ELSE
99 : IPT1 = IPT1 + 1
100 : ENDIF
101 : 10 CONTINUE
102 : * end do
103 : NBPOI2 = 0
104 : IF (NUMEL1.NE.NUMEL2) THEN
105 : NBPOI2 = 1
106 : IF (ITYP.EQ.31) THEN
107 : * les num{ros d'{l{ments croissent
108 : I6 = NUMEL1
109 : 40 CONTINUE
110 : I6 = I6 + 1
111 : IF (I6.EQ.(NOMBN1+1)) I6 = 1
112 : IF (I6.EQ.NUMEL2) GOTO 42
113 : NBPOI2 = NBPOI2 + 1
114 : GOTO 40
115 : 42 CONTINUE
116 : ELSE
117 : * les num{ros d'{l{ments d{croissent
118 : I2 = NUMEL1
119 : 30 CONTINUE
120 : I2 = I2 - 1
121 : IF (I2.EQ.0) I2 = NOMBN1
122 : IF (I2.EQ.NUMEL2) GOTO 32
123 : NBPOI2 = NBPOI2 + 1
124 : GOTO 30
125 : 32 CONTINUE
126 : ENDIF
127 : IE1 = NUMEL1
128 : DO 20 IE = 1,NBPOI2
129 : IF (ITYP.EQ.31) THEN
130 : * les num{ros d'{l{ments croissent
131 : IE1 = IE1 + 1
132 : IF (IE1.EQ.(NOMBN1+1)) IE1 = 1
133 : IE2 = ID6 + IDIM*(IE1-1)
134 : ELSE
135 : * les num{ros d'{l{ments d{croissent
136 : IE2 = ID6 + IDIM*(IE1-1)
137 : IE1 = IE1 - 1
138 : IF (IE1.EQ.0) IE1 = NOMBN1
139 : ENDIF
140 : XE1 = ZERO
141 : YE1 = ZERO
142 : DO 22 ID = 1,IDIM
143 : XX1 = XPALB(I,IE2+ID) - XPALB(I,ID2+ID)
144 : XE1 = XE1 + ( XX1 * XPALB(I,ID3+ID) )
145 : YE1 = YE1 + ( XX1 * XPALB(I,ID4+ID) )
146 : 22 CONTINUE
147 : * end do
148 : XBARY = XBARY + XE1
149 : YBARY = YBARY + YE1
150 : 20 CONTINUE
151 : * end do
152 : ENDIF
153 : NBPOIT = 2 + NBPOIN + NBPOI2
154 : XBARY = XBARY / NBPOIT
155 : YBARY = YBARY / NBPOIT
156 : *
157 : END
158 :
© Cast3M 2003 - All rights reserved.
Disclaimer