1 : C XTMX SOURCE BP208322 10/04/23 21:15:00 6661 2 : SUBROUTINE XTMX(IRE1,IRE2,VA) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8 (A-H,O-Z) 5 : REAL*8 VA,COER,VB,XTMXMU 6 : C 7 : C **** MULTIPLICATION D'UNE MATRICE(IRE2) PAR UN CHAMPPOINT (IRE1) A 8 : C **** DROITE ET A GAUCHE.LE RESULTAT EST UN FLOTTANT. 9 : C **** VA= IRE1 *IRE2 *IRE1 10 : C **** POUR EFFECTUER L OPERATION ON ELIMINE LES COMPOSANTES LX 11 : C **** DU CHPOINT ET DE LA MATRICE. ON TESTE QUE LES AUTRES INCONNUES 12 : C **** DU CHPOINT SONT INCLUSES DANS CELLES DE L OBJET RIGIDITE. 13 : C ON SUPPOSE QUE : 14 : C 1. YT ET X SONT DE MEME TYPE 15 : C 2. LA MATRICE EST CARREE 16 : C 3. LA MATRICE POSSEDE DES CORRESPONDANCES SUR LES INCONNUES 17 : C (C'EST A DIRE QUE LA IEME LIGNE EST LA DUALE DE LA IEME COLONNE) 18 : C 19 : C BP , avril 2010 : on supprime l hypothese 3. 20 : C (pour permettre l utilisation de matrices crees par imped par ex.) 21 : C 22 : -INC CCOPTIO 23 : -INC CCREEL 24 : -INC SMELEME 25 : -INC SMCHPOI 26 : -INC SMRIGID 27 : -INC SMCOORD 28 : -INC CCHAMP 29 : c 30 : CHARACTER*4 NI,INCOM 31 : SEGMENT,IHAR(0) 32 : SEGMENT,SIINC 33 : CHARACTER*4 IINC(0) 34 : ENDSEGMENT 35 : SEGMENT/ICCPR/(ICPR(NNGOT)) 36 : SEGMENT ITRAV 37 : CHARACTER*4 IINCO(NNIN) 38 : REAL*8 CC(NLIGMA),VAA(NNIN,ITES),DD(NLIGMA) 39 : INTEGER IPOS(NLIGMA) 40 : INTEGER IPOS2(NLIGMA) 41 : ENDSEGMENT 42 : LOGICAL NEEDDD 43 : 44 : C ITES = NONBRE DE NOEUD DU CHPOINT 45 : C NLIGMA = TAILLE MAX D'UNE LIGNE DE MATRICE DE RIGIDITE ELEMENTAIRE 46 : 47 : C **** INITIALISATION DU RESULTAT 48 : VA=0.D0 49 : MRIGID=IRE2 50 : MCHPOI=IRE1 51 : NNGOT=XCOOR(/1)/(IDIM+1) 52 : C 53 : C **** ON CREE LES TABLEAUX : 54 : C 55 : C **** ICPR(I)=J VEUT DIRE QUE LE NOEUD I A LE NUMERO LOCAL J. 56 : C 57 : SEGINI,ICCPR 58 : SEGACT,MCHPOI 59 : NSOUPO=IPCHP(/1) 60 : IK=0 61 : DO 1 ISOU=1,NSOUPO 62 : MSOUPO=IPCHP(ISOU) 63 : SEGACT,MSOUPO 64 : MELEME=IGEOC 65 : SEGACT,MELEME 66 : N1=NUM(/1) 67 : N2=NUM(/2) 68 : DO 2 I2=1,N2 69 : K=NUM(1,I2) 70 : * on ajoute le noeud K a ICPR(K) si pas deja vu 71 : IF(ICPR(K).NE.0) GO TO 2 72 : IK=IK+1 73 : ICPR(K)=IK 74 : 2 CONTINUE 75 : C SEGDES,MELEME 76 : C SEGDES,MSOUPO 77 : 1 CONTINUE 78 : C SEGDES,MCHPOI 79 : 80 : ITES=IK 81 : NLIGMA=0 82 : 83 : C **** REMPLISSAGE DE IINC et IHAR 84 : C = couple(inconnue primale + harmonique) de la matrice MRIGID 85 : SEGINI,SIINC 86 : SEGINI,IHAR 87 : * 88 : SEGACT,MRIGID 89 : NRIGE=IRIGEL(/1) 90 : NRIGEL=IRIGEL(/2) 91 : DESCR=IRIGEL(3,1) 92 : SEGACT,DESCR 93 : * Initialisation de la 1ere valeur 94 : IINC(**)=LISINC(1) 95 : IHAR(**)=IRIGEL(5,1) 96 : ININC=1 97 : * boucle sur les rigidites elementaires 98 : DO 3 IRI=1,NRIGEL 99 : MELEME=IRIGEL(1,IRI) 100 : SEGACT,MELEME 101 : DESCR=IRIGEL(3,IRI) 102 : NOHAR=IRIGEL(5,IRI) 103 : SEGACT,DESCR 104 : NLIGRE=LISINC(/2) 105 : IF(NLIGRE.GT.NLIGMA) NLIGMA=NLIGRE 106 : DO 7 I2=1,NLIGRE 107 : DO 8 I1=1,ININC 108 : IF(LISINC(I2).NE.IINC(I1)) GO TO 8 109 : IF(NOHAR.EQ.IHAR(I1)) GO TO 7 110 : 8 CONTINUE 111 : IINC(**)=LISINC(I2) 112 : IHAR(**)=NOHAR 113 : ININC=ININC+1 114 : 7 CONTINUE 115 : C SEGDES,DESCR 116 : C SEGDES,MELEME 117 : 3 CONTINUE 118 : C SEGDES,MRIGID 119 : C 120 : C **** ON INITIALISE LE SEGMENT ITRAV 121 : C 122 : NNIN=ININC 123 : SEGINI,ITRAV 124 : DO 10 I=1,NNIN 125 : 10 IINCO(I)=IINC(I) 126 : C 127 : C **** ON INITIALISE VAA (= chpoint) 128 : C SEGACT,MCHPOI 129 : NSOUPO=IPCHP(/1) 130 : c --- boucle sur les zones --- 131 : DO 15 ISOU=1,NSOUPO 132 : MSOUPO=IPCHP(ISOU) 133 : C SEGACT,MSOUPO 134 : MELEME=IGEOC 135 : C SEGACT,MELEME 136 : N2=NUM(/2) 137 : NC=NOCOMP(/2) 138 : MPOVAL=IPOVAL 139 : SEGACT,MPOVAL 140 : c -- boucle sur les composantes -- 141 : DO 16 INC=1,NC 142 : INCOM=NOCOMP(INC) 143 : NOHA=NOHARM(INC) 144 : DO 17 IH=1,NNIN 145 : IF(INCOM.NE.IINCO(IH)) GO TO 17 146 : IF(IHAR(IH).EQ.NOHA) GO TO 18 147 : 17 CONTINUE 148 : GO TO 16 149 : c on a trouvé le bon couple inconnue primale+harmonique : IH 150 : 18 CONTINUE 151 : DO 19 I2=1,N2 152 : IK=ICPR(NUM(1,I2)) 153 : VAA(IH,IK)= VPOCHA(I2,INC) 154 : 19 CONTINUE 155 : 16 CONTINUE 156 : SEGDES,MSOUPO 157 : SEGDES,MPOVAL 158 : SEGDES,MELEME 159 : 15 CONTINUE 160 : SEGDES,MCHPOI 161 : C 162 : C **** BOUCLE 20 SUR LES OBJETS RIGIDITES ELEMENTAIRES 163 : C 164 : C SEGACT,MRIGID 165 : DO 20 IRI=1,NRIGEL 166 : IANTI=0 167 : IF (NRIGE.GE.7) THEN 168 : IANTI=IRIGEL(7,IRI) 169 : ENDIF 170 : MELEME=IRIGEL(1,IRI) 171 : NOHA=IRIGEL(5,IRI) 172 : SEGACT,MELEME 173 : DESCR=IRIGEL(3,IRI) 174 : SEGACT,DESCR 175 : C 176 : C ** ON VERIFIE QUE: 177 : C -LA MATRICE EST CARREE 178 : LISI=LISINC(/2) 179 : LISD=LISDUA(/2) 180 : IF ( LISI.NE.LISD) THEN 180 : CALL ERREUR(21) 181 : RETURN 182 : ENDIF 183 : C -NOELED ET NOELEP SONT LES MEMES 184 : DO ITEFR=1,LISI 185 : IF( NOELED(ITEFR).NE.NOELEP(ITEFR) ) THEN 185 : CALL ERREUR(21) 186 : RETURN 187 : ENDIF 188 : ENDDO 189 : C 190 : C ** ON REMPLIT IPOS(I)=J QUI DIT QUE LA IEME INCONNUE PRIMALE 191 : C DE LA MATRICE ELEMENTAIRE EST LA JEME DE IINC 192 : DO 21 IN=1,LISI 193 : NI=LISINC(IN) 194 : DO 22 IJ=1,ININC 195 : IF(NI.NE.IINC(IJ)) GO TO 22 196 : IF(NOHA.EQ.IHAR(IJ)) GO TO 23 197 : 22 CONTINUE 198 : 23 CONTINUE 199 : IPOS(IN)=IJ 200 : 21 CONTINUE 201 : C 202 : C ** ON ETABLIT LA CORRESPONDANCE INCONNUES PRIMALES ET DUALES 203 : C (important si hypothèse 3 non vérifiée) 204 : C ** ON REMPLIT IPOS2(I)=J QUI DIT QUE LA IEME INCONNUE DUALE 205 : C DE LA MATRICE ELEMENTAIRE EST "NATURELLEMENT" ASSOCIEE A LA 206 : C JEME INCONNUE PRIMALE DE IINC 207 : C ** NEEDD nous dit si on a besoin de DD et de IPOS2 208 : NEEDDD=.false. 209 : if(IIMPI.ge.5) write(6,*) 'Pour la rigidite elementaire ',IRI 210 : DO IN=1,LISI 211 : NI=LISDUA(IN) 212 : if(IIMPI.ge.5) 213 : & write(6,*) 'l inconnue primale ',LISINC(IN), 214 : & ' produit le dual ',NI 215 : do idu=1,LNOMDU 216 : if(NOMDU(idu).eq.NI) goto 25 217 : enddo 218 : write(6,*) 'ERREUR : NOM D INCONNUE DUALE INCONNUE',NI 218 : CALL ERREUR(21) 219 : return 220 : 25 continue 221 : c on a trouve le numero du dual -> on en deduit le primal 222 : C "naturellement" associé pour le produit scalaire 223 : c il faut le chercher dans le chpoint VBB cad dans IINC 224 : NI=NOMDD(idu) 225 : DO 26 IJ=1,ININC 226 : IF(NI.NE.IINC(IJ)) GO TO 26 227 : IF(NOHA.EQ.IHAR(IJ)) GO TO 27 228 : 26 CONTINUE 229 : write(6,*) 'ERREUR : NOM D INCONNUE PRIMALE INCONNUE',NI 229 : CALL ERREUR(21) 230 : return 231 : 27 CONTINUE 232 : IPOS2(IN)=IJ 233 : if(IJ.ne.IPOS(IN)) NEEDDD=.true. 234 : ENDDO 235 : 236 : C 237 : C **** BOUCLE 30 SUR LES PETITES MATRICES D'UNE RIGIDITE ELEMENTAIRE 238 : C 239 : N1=NUM(/1) 240 : N2=NUM(/2) 241 : xMATRI=IRIGEL(4,IRI) 242 : COER=COERIG(IRI) 243 : SEGACT,xMATRI 244 : DO 30 I2=1,N2 245 : C 246 : C ** AVANT D'EFFECTUER LE PRODUIT ON VERIFIE QU'IL EST A FAIRE 247 : DO 31 I1=1,N1 248 : IF(ICPR(NUM(I1,I2)).NE.0) GO TO 32 249 : 31 CONTINUE 250 : GO TO 30 251 : 32 CONTINUE 252 : C 253 : C ** FABRICATION D'UN (ou de 2) VECTEUR(s) ISSU(s) DU CHPOINT 253 : CALL XTMXMP(LISI,CC,ICPR,NUM,I2,NOELEP,IPOS,VAA,NNIN,N1) 254 : if(NEEDDD) 254 : & CALL XTMXMP(LISI,DD,ICPR,NUM,I2,NOELEP,IPOS2,VAA,NNIN,N1) 255 : C DO 34 IN=1,LISI 256 : C 34 CC(IN)=0.D0 257 : C DO 33 IN=1,LISI 258 : C J2=ICPR(NUM(NOELEP(IN),I2)) 259 : C IF(J2.EQ.0) GO TO 33 260 : C J1=IPOS(IN) 261 : C CC(IN)=VAA(J1,J2) 262 : C 33 CONTINUE 263 : C 264 : C **** BOUCLE 35 SUR LES LIGNES D'UNE MATRICE ELEMENTAIRE 265 : * XMATRI=IMATTT(I2) 266 : * SEGACT,XMATRI 267 : if (NEEDDD) then 268 : DO 35 IN=1,LISI 269 : * IF (ABS(DD(IN)).GT.1.D-10) THEN 270 : IF (ABS(DD(IN)).GT.XPETIT) THEN 271 : VB=0.D0 272 : C ** BOUCLE 38 SUR LES COLONNES D'UNE MATRICE ELEMENTAIRE 273 : DO 38 JN=1,LISI 274 : VB=VB+CC(JN)*RE(IN,JN,i2) 275 : 38 CONTINUE 276 : VA=VA+ DD(IN)*VB*COER 277 : ENDIF 278 : 35 CONTINUE 279 : else 280 : VA = VA + XTMXMU(CC,RE(1,1,i2),LISI,IANTI)*COER 281 : endif 282 : * SEGDES,XMATRI 283 : 30 CONTINUE 284 : SEGDES,xMATRI 285 : SEGDES,DESCR 286 : SEGDES MELEME 287 : 20 CONTINUE 288 : SEGDES,MRIGID 289 : SEGSUP,ITRAV 290 : SEGSUP,SIINC 291 : SEGSUP,IHAR 292 : SEGSUP,ICCPR 293 : * 294 : END 295 : 296 : 297 : 298 : 299 : 300 : 301 : 302 : 303 : 304 : 305 : 306 :
© Cast3M 2003 - All rights reserved.
Disclaimer