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