1 : C ENSE SOURCE CHAT 09/10/09 21:17:42 6519 2 : SUBROUTINE ENSE 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : -INC SMCHPOI 6 : -INC SMELEME 7 : -INC CCOPTIO 8 : -INC SMRIGID 9 : -INC SMMATRI 10 : -INC SMSOLUT 11 : SEGMENT ITRAV(NENS) 12 : integer insym 13 : insym = 0 14 : C 14 : CALL LIROBJ ('RIGIDITE',MRIGID,1,IRETOU) 15 : IF(IERR.NE.0) RETURN 16 : SEGACT MRIGID 17 : * 18 : * ON TESTE SI IL Y A DES RIGIDITES UNILATERALES 19 : * 20 : DO 4 I=1,IRIGEL(/2) 21 : IF(IRIGEL(6,I).NE.0) THEN 21 : CALL ERREUR(433) 22 : SEGDES MRIGID 23 : RETURN 24 : ENDIF 25 : 4 CONTINUE 26 : * 27 : IIFO=IFORIG 28 : C 29 : NRG = IRIGEL(/1) 30 : NBR = IRIGEL(/2) 31 : IF(NORINC.GT.0 .AND. NORIND.GT.0) THEN 32 : INSYM = 1 33 : ENDIF 34 : IF (NRG.GE.7) THEN 35 : DO 9 IN = 1,NBR 36 : IANTI=IRIGEL(7,IN) 37 : IF(IANTI.GT.0) THEN 38 : INSYM = 1 39 : ENDIF 40 : 9 CONTINUE 41 : ENDIF 41 : CALL ECROBJ ('RIGIDITE',MRIGID) 41 : CALL RESOU 42 : IF (IERR.NE.0) RETURN 43 : SEGACT,MRIGID 44 : MRISAU=MRIGID 45 : IF (JRCOND.NE.0) THEN 46 : MRIGID=JRCOND 47 : SEGACT MRIGID 48 : ENDIF 49 : MMATRI=ICHOLE 50 : SEGACT MMATRI 51 : IF(NENS.EQ.0) THEN 52 : SEGDES MMATRI 52 : CALL ERREUR(327) 53 : RETURN 54 : ENDIF 55 : MRIGID=MRISAU 56 : C 57 : C ON MET DANS ITRAV LE NUMERO DES LIGNES OU LES MVTS D'ENSEMBLES 58 : C ONT ETE DETECTES 59 : C 60 : MILIGN=IILIGN 61 : SEGACT MILIGN 62 : SEGINI ITRAV 63 : DO 1 I=ILIGN(/1),1,-1 64 : LIGN=ILIGN(I) 65 : SEGACT LIGN 66 : DO 1501 IIJ=IMMM(/1),1,-1 67 : IN=IMMM(IIJ) 68 : IF(IN.EQ.0) GO TO 1501 69 : ITRAV(IN)=IIJ +IPREL-1 70 : IF(IN.EQ.1) GO TO 2 71 : 1501 CONTINUE 72 : SEGDES LIGN 73 : 1 CONTINUE 74 : C 75 : C ON N'A PAS TROUVER LE NOMBRE DE MODE D'ENSEMBLE VOULU 76 : C 76 : CALL ERREUR (5) 77 : SEGSUP ITRAV 78 : SEGDES MMATRI,MILIGN 79 : RETURN 80 : 2 CONTINUE 81 : C 82 : C FABRICATION DES CHPOINT SECOND MEMBRE BOUCLE 10 83 : C 84 : IPT1=IGEOMA 85 : MINCPO=IINCPO 86 : MIDUA=IIDUA 87 : MHARK=IHARK 88 : MDIAG=IDIAG 89 : SEGACT MINCPO,MIDUA,MHARK,IPT1,MDIAG 90 : NSOUPO=1 91 : NC=1 92 : N=1 93 : NBNN=1 94 : NBELEM=1 95 : NBREF=0 96 : NBSOUS=0 97 : NAT=1 98 : DO 10 I=1,NENS 99 : SEGINI MCHPOI 100 : IFOPOI=IIFO 101 : C les modes solutions sont des chpo de type diffus 102 : JATTRI(1)=2 103 : SEGINI MSOUPO 104 : IPCHP(1)=MSOUPO 105 : SEGINI MELEME 106 : IGEOC=MELEME 107 : ITYPEL=1 108 : C 109 : C RECHERCHE DU NUMERO DU NOEUD ET DU NOM DE L'INCONNUES PAR 110 : C L'INTERMEDIAIRE DU TABLEAU INCPO 111 : C 112 : IA=ITRAV(I) 113 : DO 11 J=INCPO(/2),1,-1 114 : j1=J 115 : DO 11 K=1,INCPO(/1) 116 : k1= K 117 : IF(INCPO(K,J).EQ.IA) GO TO 12 118 : 11 CONTINUE 119 : C 120 : C ERREUR PAS NORMALE 121 : C 121 : CALL ERREUR(5) 122 : RETURN 123 : 12 CONTINUE 124 : NUM(1,1)=IPT1.NUM(1,J1) 125 : NOCOMP(1)=IDUA(K1) 126 : NOHARM(1)=IHAR(K1) 127 : SEGINI MPOVAL 128 : IPOVAL=MPOVAL 129 : VPOCHA(1,1)=DIAG(IA) 130 : SEGDES MPOVAL,MELEME,MSOUPO,MCHPOI 131 : ITRAV(I)=MCHPOI 132 : 10 CONTINUE 133 : C 134 : C ON VA APPELE RESOU 135 : C 136 : SEGDES MINCPO,MIDUA,MHARK,IPT1,MDIAG 137 : SEGDES MMATRI,MRIGID,MILIGN 138 : DO 20 I=1,ITRAV(/1) 139 : ITRA=ITRAV(I) 139 : CALL ECROBJ ('CHPOINT ',ITRA) 140 : 20 CONTINUE 140 : CALL ECROBJ ('RIGIDITE',MRIGID) 140 : CALL ECRCHA ('ENSE') 140 : CALL RESOU 141 : * resou sort le nombre de modes d'ensemble 141 : CALL LIRENT(I,1,iretou) 142 : * et le maillage des noeuds contraints 142 : call lirobj('MAILLAGE',ipt8,1,iretou) 143 : IF(IERR.NE.0) RETURN 144 : DO 21 I=1,ITRAV(/1) 144 : CALL LIROBJ('CHPOINT ',ICHP,1,IRETOU) 145 : IF(IERR.NE.0) THEN 145 : CALL ERREUR(5) 146 : RETURN 147 : ENDIF 148 : MCHPOI=ITRAV(I) 149 : SEGACT MCHPOI 150 : MSOUPO=IPCHP(1) 151 : SEGACT MSOUPO 152 : MELEME=IGEOC 153 : MPOVAL=IPOVAL 154 : SEGSUP MPOVAL,MELEME 155 : SEGSUP MSOUPO 156 : SEGSUP MCHPOI 157 : ITRAV(I)=ICHP 158 : 21 CONTINUE 159 : C 160 : C ON ORTHOGONALISE LES VECTEURS LES UNS PAR RAPPORT AUX AUTRES 161 : C 162 : DO 40 I=1,ITRAV(/1) 163 : MCHPOI=ITRAV(I) 164 : C 165 : C ON CALCULE LES PRODUIT XJ * XI AVEC J < I PUIS ON FAIT 166 : C XI = XI - (XJ*XI) XJ 167 : C 168 : SEGACT MCHPOI 169 : DO 39 J = 1,IPCHP(/1) 170 : MSOUPO=IPCHP(J) 171 : SEGACT MSOUPO 172 : MPOVAL=IPOVAL 173 : SEGACT MPOVAL*MOD 174 : 39 CONTINUE 175 : IF(I.EQ.1) GO TO 47 176 : I1= I -1 177 : DO 41 J = 1,I1 178 : MCHPO1=ITRAV(J) 179 : SEGACT MCHPO1 180 : AA=0.D0 181 : NSOUPO=IPCHP(/1) 182 : DO 42 K=1,NSOUPO 183 : MSOUPO=IPCHP(K) 184 : MSOUP1=MCHPO1.IPCHP(K) 185 : SEGACT MSOUP1 186 : MPOVAL=IPOVAL 187 : MPOVA1=MSOUP1.IPOVAL 188 : SEGACT MPOVA1 189 : DO 43 L=1,VPOCHA(/2) 190 : DO 43 M=1,VPOCHA(/1) 191 : AA=AA+VPOCHA(M,L)*MPOVA1.VPOCHA(M,L) 192 : 43 CONTINUE 193 : 42 CONTINUE 194 : DO 44 K=1,NSOUPO 195 : MSOUPO=IPCHP(K) 196 : MPOVAL=IPOVAL 197 : MSOUP1=MCHPO1.IPCHP(K) 198 : MPOVA1=MSOUP1.IPOVAL 199 : DO 45 L=1,VPOCHA(/2) 200 : DO 45 M=1,VPOCHA(/1) 201 : VPOCHA(M,L)=VPOCHA(M,L)- AA * MPOVA1.VPOCHA(M,L) 202 : 45 CONTINUE 203 : 44 CONTINUE 204 : SEGDES MPOVA1,MSOUP1,MCHPO1 205 : 41 CONTINUE 206 : 47 CONTINUE 207 : C 208 : C ON NORME LE VECTEUR TROUVE 209 : C 210 : BB=0.D0 211 : DO 50 J = 1, IPCHP(/1) 212 : MSOUPO=IPCHP(J) 213 : MPOVAL=IPOVAL 214 : DO 51 K=1,VPOCHA(/2) 215 : DO 51 L=1,VPOCHA(/1) 216 : BB = BB + VPOCHA(L,K)*VPOCHA(L,K) 217 : 51 CONTINUE 218 : 50 CONTINUE 219 : IF( BB . EQ.0.D0 ) THEN 219 : CALL ERREUR(5) 220 : RETURN 221 : ENDIF 222 : CC = 1.D0/(SQRT(BB)) 223 : DO 52 J = 1, IPCHP(/1) 224 : MSOUPO=IPCHP(J) 225 : MPOVAL=IPOVAL 226 : DO 53 K=1,VPOCHA(/2) 227 : DO 53 L=1,VPOCHA(/1) 228 : VPOCHA(L,K)=VPOCHA(L,K)*CC 229 : 53 CONTINUE 230 : SEGDES MPOVAL,MSOUPO 231 : 52 CONTINUE 232 : SEGDES MCHPOI 233 : 40 CONTINUE 234 : C 235 : C ON CREE UN OBJET SOLUT PAR MODE ET ON FUSIONNE 236 : C 237 : DO 30 IIM=1,ITRAV(/1) 238 : IPCH=ITRAV(IIM) 239 : LVALM=5 240 : NIMOD=3 241 : NIPO=5 242 : SEGINI MSOLUT 243 : SEGINI MMODE 244 : MSOLIS(4)=MMODE 245 : MSOLIS(5)=IPCH 246 : IMMODD(1)=IIM 247 : MCHPOI=MSOLIS(5) 248 : SEGACT MCHPOI 249 : IF(IFOPOI.NE.1) GOTO 101 250 : ICHPOI=MCHPOI 250 : CALL NUHARM(ICHPOI,IFO,IHARM) 251 : MCHPOI=ICHPOI 252 : IF(IFO.NE.1) THEN 253 : IMMODD(2)=0 254 : IMMODD(3)=0 255 : ELSE 256 : IMMODD(2)=IHARM 257 : IF(IHARM.LT.0)IMMODD(3)=1 258 : IF(IHARM.GE.0)IMMODD(3)=2 259 : ENDIF 260 : 101 CONTINUE 261 : SEGDES MCHPOI 262 : SEGDES MMODE 263 : ITYSOL='MODE ' 264 : C 265 : C 266 : C **** ON CREE LE NOEUD NBNO+1 QUI VA ETRE ASSOCIE AU MODE. 267 : C **** ON MET CE NOEUD A L ORIGINE. IL VA SERVIR D INDICE AU MODE 268 : C 269 : ZERO=0.D0 269 : CALL CREPO1(ZERO,ZERO,ZERO,IPOIN) 270 : NBSOUS=0 271 : NBREF=0 272 : NBNN=1 273 : NBELEM=1 274 : SEGINI MELEME 275 : NUM(1,1)=IPOIN 276 : ITYPEL=1 277 : SEGDES MELEME 278 : MSOLIS(3)=MELEME 279 : C 280 : N=1 281 : DO 1100 I=4,NIPO 282 : IF(MSOLIS(I).EQ.0)GOTO 1100 283 : SEGINI MSOLEN 284 : ISOLEN(1)=MSOLIS(I) 285 : SEGDES MSOLEN 286 : MSOLIS(I)=MSOLEN 287 : GOTO (1100,1100,1100,1100,1101,1102,1102,1101,1101,1100),I 288 : 1101 CONTINUE 289 : MSOLIT(I)=2 290 : GOTO1100 291 : 1102 CONTINUE 292 : MSOLIT(I)=5 293 : 1100 CONTINUE 294 : SEGDES MSOLUT 295 : C 296 : IF(IIM.EQ.1) THEN 297 : MSOL1=MSOLUT 298 : ELSE 298 : CALL FUSOLU(MSOL1,MSOLUT,MSOL2) 299 : MSOL1=MSOL2 300 : ENDIF 301 : 30 CONTINUE 301 : CALL ECROBJ('SOLUTION',MSOL1) 302 : RETURN 303 : END 304 : 305 : 306 : 307 : 308 : 309 : 310 : 311 : 312 : 313 : 314 : 315 : 316 : 317 :
© Cast3M 2003 - All rights reserved.
Disclaimer