1 : C MANUR4 SOURCE CHAT 09/10/09 21:20:33 6519 2 : SUBROUTINE MANUR4 (IPELEM,IPDESC,MTEMP4,IPMATR,IANTI) 3 : ************************************************************************ 4 : * 5 : * M A N U R 4 6 : * ----------- 7 : * 8 : * FONCTION: 9 : * --------- 10 : * 11 : * CONSTRUCTION DES MATRICES ELEMENTAIRES DE RIGIDITE POUR UN OBJET 12 : * 'RIGIDITE' CREE MANUELLEMENT. 13 : * L'UTILISATION DE CE SOUS-PROGRAMME N'EST PAS UNIVERSELLE. 14 : * 15 : * MODE D'APPEL: 16 : * ------------- 17 : * 17 : * CALL MANUR4 (IPELEM,IPDESC,MTEMP4,IPMATR,IANTI) 18 : * 19 : * PARAMETRES: (E)=ENTREE (S)=SORTIE 20 : * ----------- 21 : * 22 : * IPELEM ENTIER (E) POINTEUR DE L'OBJET 'MAILLAGE' SUR LEQUEL 23 : * VA S'APPUYER LA 'RIGIDITE'. 24 : * IPDESC ENTIER (E) POINTEUR SUR LE SEGMENT DESCRIPTEUR DE 25 : * L'OBJET 'RIGIDITE'. 26 : * MTEMP4 SEGMENT (E) REGROUPEMENT DE POINTEURS SUR DES 27 : * 'LISTREEL'. 28 : * SOIT IL N'Y A QU'1 'LISTREEL', QUI CONTIENT 29 : * TOUS LES TERMES DE LA 30 : * MATRICE ELEMENTAIRE DE RIGIDITE, ECRITS 31 : * LIGNE PAR LIGNE, 32 : * SOIT IL Y A AUTANT DE 'LISTREEL' QUE DE 33 : * LIGNES DANS LA MATRICE ELEMENTAIRE DE 34 : * RIGIDITE, LE N-IEME 'LISTREEL' DECRIVANT LA 35 : * N-IEME LIGNE DE LA MATRICE . 36 : * IPMATR ENTIER (S) POINTEUR SUR LE SEGMENT CONTENANT LA LISTE 37 : * DES POINTEURS DES MATRICES ELEMENTAIRES DE 38 : * RIGIDITE. 39 : * 40 : * EXEMPLE DE PRESENTATION DE LA MATRICE ELEMENTAIRE: 41 : * 42 : * | A B C | 43 : * | B D E | PEUT ETRE REPRESENTEE: 44 : * | C E F | 45 : * 46 : * PAR 1 SEUL 'LISTREEL' CONTENANT: A, B,C,B, D,E, C, E, F. 47 : * PAR 3 'LISTREEL' CONTENANT: A. B C 48 : * B, D. E 49 : * C, E, F. 50 : * 51 : * LEXIQUE: (ORDRE ALPHABETIQUE) 52 : * -------- 53 : * 54 : * LONG ENTIER LONGUEUR DU 'LISTREEL' TRAITE. 55 : * NBLREE ENTIER NOMBRE DE 'LISTREEL' REFERENCES PAR "MTEMP4". 56 : * 57 : * LES AUTRES VARIABLES IMPORTANTES SONT EXPLIQUEES DANS LES MODULES 58 : * INCLUS. 59 : * 60 : * SOUS-PROGRAMMES APPELES: 61 : * ------------------------ 62 : * 63 : * ERREUR. 64 : * 65 : * AUTEUR, DATE DE CREATION: 66 : * ------------------------- 67 : * 68 : * PASCAL MANIGOT 19 FEVRIER 1985 69 : * 70 : * LANGAGE: 71 : * -------- 72 : * 73 : * ESOPE + FORTRAN77 74 : * 75 : ************************************************************************ 76 : * 77 : IMPLICIT INTEGER(I-N) 78 : -INC CCOPTIO 79 : -INC SMELEME 80 : -INC SMLREEL 81 : -INC SMRIGID 82 : * 83 : SEGMENT /MTEMP4/ (ILREEL(0)) 84 : * 85 : cdebug LOGICAL TEST 86 : * 87 : MELEME = IPELEM 88 : SEGACT,MELEME 89 : NELRIG = NUM(/2) 90 : SEGDES,MELEME 91 : * 92 : DESCR = IPDESC 93 : SEGACT,DESCR 94 : C ... La distinction entre les deux nombre est un peu artificielle, 95 : C car manur3 vérifie si les listmots sont de longueurs égales, 96 : C on en a juste besoin pour initialiser XMATRI ... 97 : NLIGRP = NOELEP(/1) 98 : NLIGRD = NOELED(/1) 99 : C ... LVAL = nombre de termes d'une matrice pleine ... 100 : LVAL = NLIGRP * NLIGRD 101 : SEGDES,DESCR 102 : * 103 : SEGINI,xMATRI 104 : IPMATR = xMATRI 105 : * SEGINI,XMATRI 106 : * DO 100 IB100=1,NELRIG 107 : * IMATTT(IB100) = XMATRI 108 : * 100 CONTINUE 109 : * END DO 110 : * SEGDES,IMATRI 111 : * 112 : * RQ: "XMATRI" EST GARDE ACTIF. 113 : * 114 : SEGACT,MTEMP4 115 : NBLREE = ILREEL(/1) 116 : * 117 : IF (NBLREE .EQ. 1) THEN 118 : * 119 : MLREEL = ILREEL(1) 120 : SEGACT,MLREEL 121 : C ... LVA1 = nombre de termes d'une matrice carrée défini par 122 : C sa moitié ... 123 : LVA1=NLIGRP*(NLIGRP+1)/2 124 : IF (LVAL .NE. PROG(/1).AND.PROG(/1).NE.LVA1 ) THEN 125 : NUMERR = 199 125 : CALL ERREUR (NUMERR) 126 : RETURN 127 : END IF 128 : * 129 : C ... ILA = N° de ligne de la matrice élémentaire ... 130 : ILA=1 131 : C ... ILC = N° de colonne de la matrice élémentaire ... 132 : ILC=1 133 : 134 : C ... ITRI dit si toutes les composantes ont été données ou 135 : C juste le triangle inférieur ... 136 : ITRI=0 137 : IF(PROG(/1).EQ.LVA1) ITRI=1 138 : IF(ITRI.EQ.1.AND.IANTI.EQ.2) THEN 138 : CALL ERREUR(731) 139 : C ... On laisse les cochonneries dans XMATRI ... 140 : * SEGDES,XMATRI 141 : C ... puis on s'en va ... 142 : RETURN 143 : ENDIF 144 : 145 : DO 200 IB200=1,PROG(/1) 146 : 147 : RE(ILA,ILC,1) = PROG(IB200) 148 : 149 : IF(ITRI.EQ.1) THEN 150 : IF(IANTI.EQ.1) THEN 151 : RE(ILC,ILA,1)=-PROG(IB200) 152 : ELSE 153 : RE(ILC,ILA,1)=PROG(IB200) 154 : ENDIF 155 : ENDIF 156 : 157 : cdebugC ... Vérif si les lignes pleines respectent la symétrie spécifiée ... 158 : cdebug IF((ITRI.EQ.0) .AND. 159 : cdebug & (IANTI.EQ.0.OR.IANTI.EQ.1) .AND. 160 : cdebug & (ILC.LE.ILA)) THEN 161 : cdebug IF(IANTI.EQ.0) TEST=RE(ILA,ILC,1).EQ.RE(ILC,ILA,1) 162 : cdebug IF(IANTI.EQ.1) TEST=RE(ILA,ILC,1).EQ.-RE(ILC,ILA,1) 163 : cdebug IF(.NOT.TEST) THEN 164 : cdebug write(*,*) 'Erreur : les lignes pleines ne ', 165 : cdebug & 'respectent pas la symétrie spécifiée !' 166 : cdebugC-à-faire boulot avec les segments 167 : cdebug return 168 : cdebug ENDIF 169 : cdebug ENDIF 170 : 171 : ILC=ILC+1 172 : C ... On passe à la ligne si on a traversé la diagonale (cas triangulaire) ... 173 : IF(ILC.GT.ILA.AND.ITRI.EQ.1) THEN 174 : ILC=1 175 : ILA=ILA+1 176 : ENDIF 177 : 178 : C ... On passe à la ligne si on est au bout (cas plein) ... 179 : IF(ILC.GT.NLIGRP) THEN 180 : ILC=1 181 : ILA=ILA+1 182 : ENDIF 183 : 184 : 200 CONTINUE 185 : do ib=2,nelrig 186 : do io=1,nligrp 187 : do iu=1,nligrd 188 : re(iu,io,ib)=re(iu,io,1) 189 : enddo 190 : enddo 191 : enddo 192 : * END DO 193 : * 194 : SEGDES,MLREEL 195 : * 196 : ELSE IF (NBLREE .GT. 1) THEN 197 : * 198 : IF (NBLREE .EQ. NLIGRD) THEN 199 : * 200 : MLREEL=ILREEL(1) 201 : SEGACT MLREEL 202 : 203 : C ... Cas triangulaire ? ... 204 : ITRI=0 205 : IF(PROG(/1).EQ.1) ITRI=1 206 : IF(ITRI.EQ.1.AND.IANTI.EQ.2) THEN 206 : CALL ERREUR(731) 207 : C ... On laisse les cochonneries dans XMATRI ... 208 : * SEGDES,XMATRI 209 : C ... puis on s'en va ... 210 : RETURN 211 : ENDIF 212 : 213 : C ... Boucle sur les lignes (IB300 = N° de la ligne) ... 214 : DO 300 IB300=1,NBLREE 215 : * 216 : MLREEL = ILREEL(IB300) 217 : SEGACT,MLREEL 218 : LONG = PROG(/1) 219 : C ... Cas lignes pleines : longueur doit être NLIGRP ... 220 : IF (ITRI.EQ.0.AND.LONG .NE. NLIGRP) THEN 221 : NUMERR = 200 221 : CALL ERREUR (NUMERR) 222 : RETURN 223 : END IF 224 : C ... Cas triangulaire : longueur doit être N° de la ligne ... 225 : IF (ITRI.EQ.1.AND.LONG.NE.IB300) THEN 226 : NUMERR = 200 226 : CALL ERREUR (NUMERR) 227 : RETURN 228 : END IF 229 : 230 : C ... Boucle sur les colonnes (IB310 = N° de la colonne) ... 231 : DO 310 IB310=1,LONG 232 : 233 : RE(IB300,IB310,1) = PROG(IB310) 234 : IF(IANTI.EQ.1.AND.ITRI.EQ.1)RE(IB310,IB300,1)=-RE(IB300,IB310,1) 235 : IF(IANTI.EQ.0.AND.ITRI.EQ.1)RE(IB310,IB300,1)=RE(IB300,IB310,1) 236 : 237 : cdebugC ... Vérif si les lignes pleines respectent la symétrie spécifiée ... 238 : cdebug IF((ITRI.EQ.0) .AND. 239 : cdebug & (IANTI.EQ.0.OR.IANTI.EQ.1) .AND. 240 : cdebug & (IB310.LE.IB300)) THEN 241 : cdebug IF(IANTI.EQ.0) TEST=RE(IB300,IB310,1).EQ.RE(IB310,IB300,1) 242 : cdebug IF(IANTI.EQ.1) TEST=RE(IB300,IB310,1).EQ.-RE(IB310,IB300,1) 243 : cdebug IF(.NOT.TEST) THEN 244 : cdebug write(*,*) 'Erreur : les lignes pleines ne ', 245 : cdebug & 'respectent pas la symétrie spécifiée !' 246 : cdebugC-à-faire boulot avec les segments 247 : cdebug return 248 : cdebug ENDIF 249 : cdebug ENDIF 250 : 251 : 310 CONTINUE 252 : * END DO 253 : * 254 : SEGDES,MLREEL 255 : * 256 : 300 CONTINUE 257 : do ib=2,nelrig 258 : do io=1,nligrp 259 : do iu=1,nligrd 260 : re(iu,io,ib)=re(iu,io,1) 261 : enddo 262 : enddo 263 : enddo 264 : * END DO 265 : 266 : C ... c.à.d. le nombre de LISTREEL est différent du nombre de variables duales ... 267 : ELSE 268 : * 269 : NUMERR = 201 269 : CALL ERREUR (NUMERR) 270 : RETURN 271 : * 272 : END IF 273 : * 274 : ELSE 275 : * 276 : * AUCUN 'LISTREEL' N'A ETE FOURNI EN DONNEE. 277 : MOTERR(1:8) = 'LISTREEL' 278 : NUMERR = 37 278 : CALL ERREUR (NUMERR) 279 : RETURN 280 : * 281 : END IF 282 : * 283 : SEGDES,XMATRI 284 : SEGDES,MTEMP4 285 : * 286 : END 287 : 288 : 289 : 290 : 291 : 292 : 293 :
© Cast3M 2003 - All rights reserved.
Disclaimer