1 : C YTMXMU SOURCE CHAT 09/10/09 21:26:30 6519 2 : SUBROUTINE YTMXMU(IRE1,JSE2,JVAL,IRE3,JVSE) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : C 6 : C **** ON PART DU PRINCIPE QUE TOUS LES CHPOINTS SONT IDENTIQUES 7 : C ET QUE LA MATRICE EST SYMETRIQUE. CE SUBROUTINE N'EST 8 : C APPELE QUE PAR SUPMAS. 9 : C 10 : C **** MULTIPLICATION D'UNE MATRICE(IRE3) PAR UN CHAMPPOINT (IRE1) A 11 : C **** GAUCHE ET PAR DES CHAMPPOINTS ISE2(JVAL) A DROITE. 12 : C **** VSE(J)= IRE1 *IRE3 *ISE2(J) 13 : C 14 : C **** ON PART DU PRINCIPE QUE TOUS LES CHPOINTS SONT IDENTIQUES 15 : C 16 : C **** POUR EFFECTUER L'OPERATION ON ELIMINE LES COMPOSANTES LX 17 : C **** DU CHPOINT ET DE LA RIGIDITE. ON TESTE QUE LES AUTRES INCONNUES 18 : C **** DU CHPOINT SONT INCLUSES DANS CELLES DE L OBJET RIGIDITE 19 : C 20 : -INC CCOPTIO 21 : -INC SMELEME 22 : -INC SMCHPOI 23 : -INC SMRIGID 24 : -INC SMCOORD 25 : CHARACTER*4 NI,INCOM 26 : SEGMENT,ISE2(LL) 27 : SEGMENT,VSE(LL)*D 28 : SEGMENT,MPO(LL) 29 : SEGMENT,IHAR(0) 30 : SEGMENT,SIINC 31 : CHARACTER*4 IINC(0) 32 : ENDSEGMENT 33 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 34 : SEGMENT/ITRAV/(CC(NLIGMA)*D,DD(KSIM,NLIGMA)*D, 35 : *VAA(KSIM,NNIN,ITES)*D,VBB(NNIN,ITES)*D) 36 : SEGMENT IPOS(NLIGMA) 37 : SEGMENT SIINCO 38 : CHARACTER*4 IINCO(NNIN) 39 : ENDSEGMENT 40 : C ITES EST LE NONBRE DE NOEUD DU CHAMPPOINT. NLIGMA EST LA TAILLE 41 : C MAX D'UNE LIGNE DE MATRICE DE RIGIDITE ELEMENTAIRE. 42 : * WRITE(6,9001) 43 : *9001 FORMAT(' IMPRESSION NUMERO 1') 44 : KSIM=JVAL 45 : VSE=JVSE 46 : ISE2=JSE2 47 : SEGACT VSE*MOD,ISE2 48 : LL=JVAL 49 : SEGINI MPO 50 : DO 4597 KN=1,JVAL 51 : VSE(KN)=0.D0 52 : 4597 CONTINUE 53 : * WRITE(6,9002) 54 : *9002 FORMAT(' IMPRESSION NUMERO 2') 55 : C 56 : C ****ON RETIRE DES CHPOINTS LES MULT. DE LAGRANGE S'IL Y EN A. 57 : C 58 : C 59 : C **** ON CREE LES TABLEAUX : 60 : C **** ICPR(I)=J VEUT DIRE QUE LE NOEUD I A LE NUMERO LOCAL J. 61 : C **** ON COMMENCE PAR RECENSER LES NOEUDS DU CHAMPPOINT. 62 : C 63 : SEGINI ICPR 64 : KMAX=XCOOR(/1)/(IDIM+1) 65 : DO 6 K=1,KMAX 66 : ICPR(K)=0 67 : 6 CONTINUE 68 : IK=0 69 : MCHPOI=IRE1 70 : SEGACT,MCHPOI 71 : NSOUPO=IPCHP(/1) 72 : DO 1 ISOU=1,NSOUPO 73 : MSOUPO=IPCHP(ISOU) 74 : SEGACT,MSOUPO 75 : MELEME=IGEOC 76 : SEGACT,MELEME 77 : N2=NUM(/2) 78 : DO 2 I2=1,N2 79 : K=NUM(1,I2) 80 : IF(ICPR(K).NE.0) GO TO 2 81 : IK=IK+1 82 : ICPR(K)=IK 83 : 2 CONTINUE 84 : SEGDES,MELEME 85 : SEGDES,MSOUPO 86 : 1 CONTINUE 87 : SEGDES,MCHPOI 88 : ITES=IK 89 : * WRITE(6,9003) 90 : *9003 FORMAT(' IMPRESSION NUMERO 3') 91 : C 92 : C **** ON INITIALISE LES INCONNUES A PRTIR DE LA MATRICE 93 : C 94 : NLIGMA=0 95 : SEGINI,SIINC 96 : SEGINI,IHAR 97 : MRIGID=IRE3 98 : SEGACT,MRIGID 99 : NRIGEL=IRIGEL(/2) 100 : DESCR=IRIGEL(3,1) 101 : SEGACT,DESCR 102 : IINC(**)=LISINC(1) 103 : IHAR(**)=IRIGEL(5,1) 104 : ININC=1 105 : DO 3 IRI=1,NRIGEL 106 : MELEME=IRIGEL(1,IRI) 107 : SEGACT,MELEME 108 : DESCR=IRIGEL(3,IRI) 109 : NOHA=IRIGEL(5,IRI) 110 : SEGACT,DESCR 111 : NLIGRE=LISINC(/2) 112 : IF(NLIGRE.GT.NLIGMA) NLIGMA=NLIGRE 113 : DO 7 I2=1,NLIGRE 114 : DO 8 I1=1,ININC 115 : IF(LISINC(I2).NE.IINC(I1)) GO TO 8 116 : IF(NOHA.EQ.IHAR(I1)) GO TO 7 117 : 8 CONTINUE 118 : IINC(**)=LISINC(I2) 119 : IHAR(**)=NOHA 120 : ININC=ININC+1 121 : 7 CONTINUE 122 : SEGDES,DESCR 123 : SEGDES MELEME 124 : 3 CONTINUE 125 : SEGDES,MRIGID 126 : * WRITE(6,9004) 127 : *9004 FORMAT(' IMPRESSION NUMERO 4') 128 : C 129 : C **** ON INITIALISE LE SEGMENT MTRAV 130 : C 131 : NNIN=ININC 132 : SEGINI SIINCO,IPOS 133 : DO 10 I=1,NNIN 134 : 10 IINCO(I)=IINC(I) 135 : SEGINI ITRAV 135 : CALL ZERO(CC,NLIGMA,1) 135 : CALL ZERO(DD,NLIGMA,KSIM) 135 : CALL ZERO(VAA,KSIM*NNIN,ITES) 135 : CALL ZERO(VBB,NNIN,ITES) 136 : C 137 : C **** ON INITIALISE IVECT QUI DIRA TOUTES LES INCONNUES EXISTANTES DA 138 : C **** LE CHAMPOINT. ON SUPPOSE QUE PAREIL POUR TOUS LES CHPOINTS 139 : C 140 : MCHPOI=IRE1 141 : DO 1543 KJI = 1, JVAL 142 : MCHPO1=ISE2(KJI) 143 : SEGACT MCHPO1 144 : 1543 CONTINUE 145 : SEGACT,MCHPOI 146 : NSOUPO=IPCHP(/1) 147 : * WRITE(6,9005) 148 : *9005 FORMAT(' IMPRESSION NUMERO 5') 149 : DO 15 ISOU=1,NSOUPO 150 : MSOUPO=IPCHP(ISOU) 151 : SEGACT,MSOUPO 152 : MELEME=IGEOC 153 : SEGACT,MELEME 154 : MPOVAL=IPOVAL 155 : SEGACT,MPOVAL 156 : DO 1544 KJI=1,JVAL 157 : MCHPO1=ISE2(KJI) 158 : MSOUP1=MCHPO1.IPCHP(ISOU) 159 : SEGACT MSOUP1 160 : MPOVA1=MSOUP1.IPOVAL 161 : SEGACT MPOVA1 162 : MPO(KJI)=MPOVA1 163 : SEGDES MSOUP1 164 : 1544 CONTINUE 165 : SEGACT,MSOUPO 166 : N2=VPOCHA(/1) 167 : NC=VPOCHA(/2) 168 : DO 16 INC=1,NC 169 : INCOM=NOCOMP(INC) 170 : NOHA=NOHARM(INC) 171 : DO 17 IH=1,NNIN 172 : IF(INCOM.NE.IINCO(IH)) GO TO 17 173 : IF(NOHA.EQ.IHAR(IH)) GO TO 18 174 : 17 CONTINUE 175 : GO TO 16 176 : 18 CONTINUE 177 : DO 191 I2=1,N2 178 : IK=ICPR(NUM(1,I2)) 179 : VBB(IH,IK)=VPOCHA(I2,INC) 180 : 191 CONTINUE 181 : DO 190 KJI=1,JVAL 182 : MPOVA1=MPO(KJI) 183 : DO 19 I2=1,N2 184 : IK=ICPR(NUM(1,I2)) 185 : VAA(KJI,IH,IK)=MPOVA1.VPOCHA(I2,INC) 186 : 19 CONTINUE 187 : 190 CONTINUE 188 : 16 CONTINUE 189 : DO 1545 KJI=1,JVAL 190 : MPOVA1=MPO(KJI) 191 : SEGDES MPOVA1 192 : 1545 CONTINUE 193 : SEGDES,MSOUPO 194 : SEGDES,MPOVAL 195 : SEGDES,MELEME 196 : 15 CONTINUE 197 : * WRITE(6,9006) 198 : *9006 FORMAT(' IMPRESSION NUMERO 6') 199 : SEGDES,MCHPOI 200 : DO 1546 KJI=1,JVAL 201 : MCHPO1=ISE2(KJI) 202 : SEGDES MCHPO1 203 : 1546 CONTINUE 204 : C 205 : C **** BOUCLE 20 SUR LES OBJETS RIGIDITES ELEMENTAIRES 206 : C 207 : SEGACT,MRIGID 208 : DO 20 IRI=1,NRIGEL 209 : MELEME=IRIGEL(1,IRI) 210 : SEGACT,MELEME 211 : DESCR=IRIGEL(3,IRI) 212 : SEGACT,DESCR 213 : LISI=LISINC(/2) 214 : C 215 : C **** ON REMPLIT IPOS(I)=J QUI DIT QUE LA IEME INCONNUES 216 : C **** DE LA MATRICE ELEMENTAIRE EST LA JEME DE IINC 217 : C 218 : NOHA=IRIGEL(5,IRI) 219 : DO 21 IN=1,LISI 220 : NI=LISINC(IN) 221 : DO 22 IJ=1,ININC 222 : IF(NI.NE.IINC(IJ)) GO TO 22 223 : IF(NOHA.EQ.IHAR(IJ)) GO TO 23 224 : 22 CONTINUE 225 : 23 CONTINUE 226 : IPOS(IN)=IJ 227 : 21 CONTINUE 228 : C 229 : C **** BOUCLE 30 SUR TOUTES LES PETITES MATRICES D'UN OBJET 230 : C **** RIGIDITE ELEMENTAIRE. 231 : C 232 : N1=NUM(/1) 233 : N2=NUM(/2) 234 : xMATRI=IRIGEL(4,IRI) 235 : SEGACT,xMATRI 236 : COER=COERIG(IRI) 237 : DO 30 I2=1,N2 238 : C 239 : C **** AVANT D'EFFECTUER LE PRODUIT ON VERIFIE QU'IL EST A FAIRE 240 : C 241 : DO 31 I1=1,N1 242 : IF(ICPR(NUM(I1,I2)).NE.0) GO TO 32 243 : 31 CONTINUE 244 : GO TO 30 245 : 32 CONTINUE 246 : C 247 : C **** FABRICATION D'UN VECTEUR ISSU DU CHAMPPOINT DE DIMENSION NLIGRE 248 : C 249 : DO 33 IN=1,LISI 250 : CC(IN)=0.D0 251 : J2=ICPR(NUM(NOELEP(IN),I2)) 252 : IF(J2.EQ.0) GO TO 33 253 : J1=IPOS(IN) 254 : CC(IN)=VBB(J1,J2) 255 : 33 CONTINUE 256 : DO 331 KN=1,JVAL 257 : DO 330 IN=1,LISI 258 : DD(KN,IN)=0.D0 259 : J2=ICPR(NUM(NOELEP(IN),I2)) 260 : IF(J2.EQ.0) GO TO 330 261 : J1=IPOS(IN) 262 : DD(KN,IN)=VAA(KN,J1,J2) 263 : 330 CONTINUE 264 : 331 CONTINUE 265 : C 266 : C **** BOUCLE 35 SUR LES LIGNES D'UNE MATRICE ELEMENTAIRE 267 : C 268 : * XMATRI=IMATTT(I2) 269 : * SEGACT,XMATRI 270 : DO 35 IN=1,LISI 271 : VB=0.D0 272 : DO 38 JN=1,LISI 273 : * IF(JN.GT.IN) GO TO 36 274 : * IKO=(IN-1)*IN/2+JN 275 : * GO TO 37 276 : * 36 CONTINUE 277 : * IKO=(JN-1)*JN/2+IN 278 : * 37 VB=VB+CC(JN)*RE(JN,IN,i2) 279 : VB=VB+CC(JN)*RE(JN,IN,i2) 280 : 38 CONTINUE 281 : VB=VB*COER 282 : DO 350 KN=1,JVAL 283 : VSE(KN)=VSE(KN)+VB*DD(KN,IN) 284 : 350 CONTINUE 285 : 35 CONTINUE 286 : * SEGDES,XMATRI 287 : 30 CONTINUE 288 : SEGDES,xMATRI 289 : SEGDES,DESCR 290 : 24 SEGDES MELEME 291 : 20 CONTINUE 292 : SEGDES,MRIGID,ISE2,VSE 293 : SEGSUP,ITRAV 294 : SEGSUP,SIINC 295 : SEGSUP,IHAR 296 : SEGSUP ICPR,SIINCO,IPOS,MPO 297 : 5000 CONTINUE 298 : RETURN 299 : END 300 : 301 :
© Cast3M 2003 - All rights reserved.
Disclaimer