1 : C ACTIPO SOURCE CHAT 05/10/20 21:15:01 5219 2 : SUBROUTINE ACTIPO(FLOT,IDET,MCHPO1,MCHPO2,MCHPO3,MCHPO4) 3 : C-------------------------------------------------------------------- 4 : C ACCELERATION POUR DES CHAMPOINTS 5 : C-------------------------------------------------------------------- 6 : IMPLICIT INTEGER(I-N) 7 : IMPLICIT REAL*8(A-H,O-Z) 8 : -INC CCOPTIO 9 : -INC SMCHPOI 10 : -INC SMELEME 11 : -INC SMCOORD 12 : -INC CCREEL 13 : CHARACTER*4 NAMEU(9),NAMEF(9) 14 : SEGMENT SNOMIN 15 : CHARACTER*4 NOMIN(0) 16 : ENDSEGMENT 17 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 18 : SEGMENT/MTRAV/(VA(NIN,KPOI)*D,VB(NIN,KPOI)*D,VC(NIN,KPOI)*D 19 : . ,VD(NIN,KPOI)*D,IBIN(NIN,KPOI),IPASS(NIN)) 20 : SEGMENT/MTRBV/(VF(NIN,KPOI)*D) 21 : DATA NAMEU(1),NAMEU(2),NAMEU(3)/'UX ','UY ','UZ '/ 22 : DATA NAMEU(4),NAMEU(5),NAMEU(6)/'RX ','RY ','RZ '/ 23 : DATA NAMEU(7),NAMEU(8),NAMEU(9)/'UR ','UT ','RT '/ 24 : DATA NAMEF(1),NAMEF(2),NAMEF(3)/'FX ','FY ','FZ '/ 25 : DATA NAMEF(4),NAMEF(5),NAMEF(6)/'MX ','MY ','MZ '/ 26 : DATA NAMEF(7),NAMEF(8),NAMEF(9)/'FR ','FT ','MT '/ 27 : DATA BINF,BSUP/1.D-2,1.D2/ 28 : xp100=xpetit * 100. 29 : C 30 : C ** ON FABRIQUE UN ICPR SUR LE 3 EME CHPOINT 31 : C 32 : SEGACT MCOORD 33 : SEGINI ICPR 34 : SEGINI SNOMIN 35 : MCHPOI=MCHPO3 36 : SEGACT MCHPOI 37 : KPOI=0 38 : DO 1 I = 1,IPCHP(/1) 39 : MSOUPO=IPCHP(I) 40 : SEGACT MSOUPO 41 : MELEME=IGEOC 42 : SEGACT MELEME 43 : DO 2 K=1,NUM(/2) 44 : IP=NUM(1,K) 45 : IF(ICPR(IP).NE.0) GO TO 2 46 : KPOI=KPOI+1 47 : ICPR(IP)=KPOI 48 : 2 CONTINUE 49 : SEGDES MELEME 50 : C 51 : C ** RECHERCHE DE TOUTES LES INCONNUES DE CE CHPOINT 52 : C 53 : IF(I.NE.1) GO TO 3 54 : DO 4 K=1,NOCOMP(/2) 55 : NOMIN(**)=NOCOMP(K) 56 : 4 CONTINUE 57 : GO TO 7 58 : 3 CONTINUE 59 : NN=NOMIN(/2) 60 : DO 5 K=1,NOCOMP(/2) 61 : DO 6 KK=1,NN 62 : IF(NOMIN(KK).EQ.NOCOMP(K)) GO TO 5 63 : 6 CONTINUE 64 : NOMIN(**)=NOCOMP(K) 65 : 5 CONTINUE 66 : 7 CONTINUE 67 : SEGDES MSOUPO 68 : 1 CONTINUE 69 : NIN=NOMIN(/2) 70 : SEGINI MTRAV 71 : C 72 : C ON RECUPERE LE 3-EME CHAMP MIS DANS VA 73 : C 74 : DO 10 I=1,IPCHP(/1) 75 : MSOUPO=IPCHP(I) 76 : SEGACT MSOUPO 77 : MELEME=IGEOC 78 : SEGACT MELEME 79 : MPOVAL=IPOVAL 80 : SEGACT MPOVAL 81 : DO 11 K=1,NOCOMP(/2) 82 : DO 12 KK=1,NIN 83 : IF(NOMIN(KK).EQ.NOCOMP(K)) GO TO 13 84 : 12 CONTINUE 85 : 13 CONTINUE 86 : IPASS(K)=KK 87 : 11 CONTINUE 88 : DO 14 K=1,NUM(/2) 89 : DO 14 KK=1,NOCOMP(/2) 90 : K1=IPASS(KK) 91 : K2= ICPR(NUM(1,K)) 92 : IBIN(K1,K2)=1 93 : VA(K1,K2)=VPOCHA(K,KK) 94 : VD(K1,K2)=VPOCHA(K,KK) 95 : 14 CONTINUE 96 : SEGDES MPOVAL,MELEME,MSOUPO 97 : 10 CONTINUE 98 : SEGDES MCHPOI 99 : C 100 : C ON RECUPERE LE 2-EME CHAMP MIS DANS VB 101 : C 102 : MCHPOI=MCHPO2 103 : SEGACT MCHPOI 104 : DO 20 I=1,IPCHP(/1) 105 : MSOUPO=IPCHP(I) 106 : SEGACT MSOUPO 107 : MELEME=IGEOC 108 : SEGACT MELEME 109 : MPOVAL=IPOVAL 110 : SEGACT MPOVAL 111 : DO 29 K=1,NIN 112 : IPASS(K)=0 113 : 29 CONTINUE 114 : DO 21 K=1,NOCOMP(/2) 115 : DO 22 KK=1,NIN 116 : IF(NOMIN(KK).EQ.NOCOMP(K)) GO TO 23 117 : 22 CONTINUE 118 : GO TO 21 119 : 23 CONTINUE 120 : IPASS(K)=KK 121 : 21 CONTINUE 122 : DO 28 K=1,NUM(/2) 123 : K2= ICPR(NUM(1,K)) 124 : IF(K2.EQ.0) GO TO 28 125 : DO 24 KK=1,NOCOMP(/2) 126 : K1=IPASS(KK) 127 : IF(K1.EQ.0) GO TO 24 128 : VB(K1,K2)=VPOCHA(K,KK) 129 : 24 CONTINUE 130 : 28 CONTINUE 131 : SEGDES MPOVAL,MELEME,MSOUPO 132 : 20 CONTINUE 133 : SEGDES MCHPOI 134 : C 135 : C ON RECUPERE LE 1-ER CHAMP MIS DANS VC 136 : C 137 : MCHPOI=MCHPO1 138 : SEGACT MCHPOI 139 : DO 30 I=1,IPCHP(/1) 140 : MSOUPO=IPCHP(I) 141 : SEGACT MSOUPO 142 : MELEME=IGEOC 143 : SEGACT MELEME 144 : MPOVAL=IPOVAL 145 : SEGACT MPOVAL 146 : DO 39 K=1,NIN 147 : IPASS(K)=0 148 : 39 CONTINUE 149 : DO 31 K=1,NOCOMP(/2) 150 : DO 32 KK=1,NIN 151 : IF(NOMIN(KK).EQ.NOCOMP(K)) GO TO 33 152 : 32 CONTINUE 153 : GO TO 31 154 : 33 CONTINUE 155 : IPASS(K)=KK 156 : 31 CONTINUE 157 : DO 38 K=1,NUM(/2) 158 : K2= ICPR(NUM(1,K)) 159 : IF(K2.EQ.0) GO TO 38 160 : DO 34 KK=1,NOCOMP(/2) 161 : K1=IPASS(KK) 162 : IF(K1.EQ.0) GO TO 34 163 : VC(K1,K2)=VPOCHA(K,KK) 164 : 34 CONTINUE 165 : 38 CONTINUE 166 : SEGDES MPOVAL,MELEME,MSOUPO 167 : 30 CONTINUE 168 : SEGDES MCHPOI 169 : C 170 : GO TO (2001,2002),IDET 171 : C 172 : C ACCELERATION GEOMETRIQUE 173 : C 174 : 2001 CONTINUE 175 : DO 41 K=1,KPOI 176 : DO 42 I=1,NIN 177 : RR=VA(I,K) 178 : IF(IBIN(I,K).EQ.0) GO TO 42 179 : RD=VB(I,K)-VC(I,K) 180 : IF(abs(rd).lt.xp100) GO TO 43 181 : RAI=(VA(I,K)-VB(I,K))/RD 182 : IF(ABS(RAI).GT.FLOT) GO TO 43 183 : IF(abs(1.D0-RAI).LE.xp100) GO TO 43 184 : RR=VA(I,K)+(VA(I,K)-VB(I,K))*RAI/(1.D0-RAI) 185 : 43 CONTINUE 186 : VD(I,K)=RR 187 : 42 CONTINUE 188 : 41 CONTINUE 189 : GO TO 3000 190 : C 191 : C ACCELERATION SECANTE 192 : C 193 : 2002 CONTINUE 194 : C 195 : C ON RECUPERE LE DERNIER CHAMP DANS VF 196 : C 197 : SEGINI MTRBV 198 : MCHPOI=MCHPO4 199 : SEGACT MCHPOI 200 : DO 70 I=1,IPCHP(/1) 201 : MSOUPO=IPCHP(I) 202 : SEGACT MSOUPO 203 : MELEME=IGEOC 204 : SEGACT MELEME 205 : MPOVAL=IPOVAL 206 : SEGACT MPOVAL 207 : DO 79 K=1,NIN 208 : IPASS(K)=0 209 : 79 CONTINUE 210 : DO 71 K=1,NOCOMP(/2) 211 : DO 710 KN=1,9 212 : IF(NAMEF(KN).EQ.NOCOMP(K)) GO TO 720 213 : 710 CONTINUE 214 : GO TO 71 215 : 720 CONTINUE 216 : DO 72 KK=1,NIN 217 : IF(NOMIN(KK).EQ.NAMEU(KN)) GO TO 73 218 : 72 CONTINUE 219 : GO TO 71 220 : 73 CONTINUE 221 : IPASS(K)=KK 222 : 71 CONTINUE 223 : DO 78 K=1,NUM(/2) 224 : K2= ICPR(NUM(1,K)) 225 : IF(K2.EQ.0) GO TO 78 226 : DO 74 KK=1,NOCOMP(/2) 227 : K1=IPASS(KK) 228 : IF(K1.EQ.0) GO TO 74 229 : VF(K1,K2)=VPOCHA(K,KK) 230 : 74 CONTINUE 231 : 78 CONTINUE 232 : SEGDES MPOVAL,MELEME,MSOUPO 233 : 70 CONTINUE 234 : SEGDES MCHPOI 235 : C 236 : ZNUM=0.D0 237 : ZDENOM=0.D0 238 : DO 761 K=1,KPOI 239 : DO 762 I=1,NIN 240 : IF(IBIN(I,K).EQ.0) GO TO 762 241 : ZNUM=ZNUM+VF(I,K)*VC(I,K) 242 : ZDENOM=ZDENOM+VF(I,K)*(VC(I,K)+VB(I,K)-VA(I,K)) 243 : 762 CONTINUE 244 : 761 CONTINUE 245 : IF(ZDENOM.EQ.0.D0) XMU=1.D0 246 : IF(ZDENOM.NE.0.D0) XMU=ZNUM/ZDENOM 247 : IF(ABS(XMU).LT.BINF.OR.ABS(XMU).GT.BSUP) XMU=1.D0 248 : IF(XMU.EQ.0.D0) XMU=1.D0 249 : XMUN=1.D0-XMU 250 : DO 771 K=1,KPOI 251 : DO 772 I=1,NIN 252 : IF(IBIN(I,K).EQ.0) GO TO 772 253 : VD(I,K)=XMU*VA(I,K)+XMUN*VC(I,K) 254 : 772 CONTINUE 255 : 771 CONTINUE 256 : C 257 : 3000 CONTINUE 258 : SEGACT MCHPO3 259 : SEGINI,MCHPOI=MCHPO3 260 : DO 50 I=1,IPCHP(/1) 261 : MSOUP1=MCHPO3.IPCHP(I) 262 : SEGACT MSOUP1 263 : SEGINI,MSOUPO=MSOUP1 264 : IPCHP(I)=MSOUPO 265 : MPOVA1=MSOUP1.IPOVAL 266 : SEGINI,MPOVAL=MPOVA1 267 : IPOVAL=MPOVAL 268 : MELEME=IGEOC 269 : SEGACT MELEME 270 : DO 51 KK=1,NOCOMP(/2) 271 : DO 52 K=1,NOMIN(/2) 272 : IF(NOMIN(K).EQ.NOCOMP(KK)) GO TO 53 273 : 52 CONTINUE 273 : CALL ERREUR ( 5 ) 274 : RETURN 275 : 53 CONTINUE 276 : KPA=K 277 : DO 54 K=1,NUM(/2) 278 : IP=ICPR(NUM(1,K)) 279 : VPOCHA(K,KK)=VD(KPA,IP) 280 : 54 CONTINUE 281 : 51 CONTINUE 282 : SEGDES MPOVAL,MSOUPO,MELEME,MSOUP1 283 : 50 CONTINUE 284 : SEGDES MCHPOI,MCHPO3 285 : SEGSUP SNOMIN,ICPR,MTRAV 286 : IF(IDET.EQ.2) SEGSUP MTRBV 286 : CALL ECROBJ('CHPOINT',MCHPOI) 287 : RETURN 288 : END 289 : 290 :
© Cast3M 2003 - All rights reserved.
Disclaimer