1 : C FX2LX SOURCE BP208322 13/12/20 21:15:07 7890 2 : 3 : SUBROUTINE FX2LX(IPRIG1,ILMOT1,IPRIGI) 4 : C======================================================================== 5 : C MODIF DE RIGIDITE POUR TRANSFORMER LES INCONNUEs PRIMALEs FX EN LX 6 : C 27/07/2012 7 : c IPRIG1 : MRIGID initial (avec composantes ILMOT1 = FX ...) 8 : c actif en entree 9 : c IPRIGI : MRIGID final (avec composante FLX) 10 : c actif en sortie 11 : C======================================================================== 12 : 13 : IMPLICIT INTEGER(I-N) 14 : IMPLICIT REAL*8 (A-H,O-Z) 15 : 16 : -INC CCREEL 17 : -INC CCOPTIO 18 : -INC SMCOORD 19 : -INC SMELEME 20 : -INC SMRIGID 21 : -INC SMLMOTS 22 : 23 : 24 : SEGMENT MTRAV 25 : INTEGER INC2LX(3,NBLX) 26 : ENDSEGMENT 27 : LOGICAL FLELIM 28 : CHARACTER*4 MOINC1,MOINC,MODUA1,MODUA 29 : * rem : dimension de itoto et jtoto en dur pour l'instant ... 30 : c INTEGER itoto(100),jtoto(100) 31 : INTEGER itoto(100) 32 : 33 : 34 : c----------------------------------------------------- 35 : c RECUPERATION DES ENTREES 36 : c----------------------------------------------------- 37 : MLMOT1 = ILMOT1 38 : nmot1 = MLMOT1.MOTS(/2) 39 : RI1 = IPRIG1 40 : NRIGE1 = RI1.IRIGEL(/2) 41 : 42 : NBPTS = XCOOR(/1)/(IDIM+1) 43 : 44 : NBLX = 1000 45 : segini,MTRAV 46 : nlx=0 47 : 48 : c----------------------------------------------------- 49 : c PREPARATION DE LA RIGIDITE DE SORTIE 50 : c----------------------------------------------------- 51 : NRIGEL = 0 52 : segini,MRIGID 53 : IPRIGI=MRIGID 54 : MTYMAT = RI1.MTYMAT 55 : 56 : 57 : c==== Boucle sur les sous rigidites ============================== 58 : DO 1000 ityty=1,NRIGE1 59 : 59 : c call ZERO(INC2LX,3,NBLX) 60 : cbp -> routine ZERO seulement pour les reels 61 : DO 100 Izero=1,3 62 : DO 100 Jzero=1,NBLX 63 : INC2LX(Izero,Jzero)=0 64 : 100 CONTINUE 65 : 66 : c------ Recup ------------------------- 67 : XCOE1 = RI1.COERIG(ityty) 68 : IPT1 = RI1.IRIGEL(1,ityty) 69 : DES1 = RI1.IRIGEL(3,ityty) 70 : XMATR1 = RI1.IRIGEL(4,ityty) 71 : NIFOU1 = RI1.IRIGEL(5,ityty) 72 : 73 : c------ combien d'inconnues sont a séparer ? -------------------- 74 : segact,DES1 75 : NLIGP1 = DES1.LISINC(/2) 76 : nbinc1=0 77 : FLELIM=.true. 78 : do 1010 iinc1=1,NLIGP1 79 : c va t'on trouvé cette inconnue ? 80 : do imot1=1,nmot1 81 : if(MLMOT1.MOTS(imot1).eq.DES1.LISINC(iinc1))then 82 : if(FLELIM)then 83 : nbinc1 = nbinc1 + 1 84 : if(iimpi.ge.3) 85 : & write(ioimp,*) iinc1,'ieme inconnue ',MLMOT1.MOTS(imot1) 86 : & ,'detectee comme étant a remplacer par un LX ',nbinc1 87 : goto 1010 88 : else 89 : write(ioimp,*) iinc1,'ieme inconnue ',MLMOT1.MOTS(imot1) 90 : & ,'detectee comme étant a remplacer par un LX mal positionnée !' 90 : call ERREUR(21) 91 : endif 92 : endif 93 : enddo 94 : c on s arrete car on suppose toutes celles a trouvées sont au debut 95 : c goto 1011 96 : c on va vérifier cette affirmation en continuant la boucle 97 : FLELIM=.false. 98 : 1010 continue 99 : 1011 continue 100 : if(FLELIM)then 101 : write(ioimp,*) 'On ne peut pas eliminer toutes les inconnues' 101 : call ERREUR(21) 102 : endif 103 : if(nbinc1.eq.0) goto 1000 104 : 105 : c------ boucle sur les elements -------------------------------------- 106 : segact,IPT1 107 : segact,XMATR1*mod 108 : NBNN1 = IPT1.NUM(/1) 109 : NBEL1 = IPT1.NUM(/2) 110 : do 1020 iel1=1,NBEL1 111 : 112 : c-------- boucle sur les inconnues a remplacer -------------------- 113 : do 1021 iinc1=1,nbinc1 114 : 115 : c -LX existe-il deja? (<=> a t'on deja vu cet noeud+inconnue?) 116 : ino1 = IPT1.NUM(iinc1,iel1) 117 : IBPTS=0 118 : if(nlx.gt.0) then 119 : do ilx=1,nlx 120 : if (INC2LX(2,ilx).eq.ino1) then 121 : if (INC2LX(3,ilx).eq.imot1) then 122 : IBPTS = INC2LX(1,ilx) 123 : if(iimpi.ge.3) 124 : & write(ioimp,*) iinc1,'ieme inconnue ',DES1.LISINC(iinc1) 125 : & ,'detectee comme étant a remplacer par un LX ',nbinc1 126 : goto 1022 127 : endif 128 : endif 129 : enddo 130 : endif 131 : 132 : c -si ce LX n'existe pas il faut le créer et ajouter le irigel 133 : 134 : c on ajoute ce LX au tableau des inconnues a transformer 135 : NBPTS=NBPTS+1 136 : nlx=nlx+1 137 : if(nlx.gt.NBLX) then 138 : NBLX = NBLX + 1000 139 : segadj,MTRAV 140 : endif 141 : INC2LX(1,nlx)=NBPTS 142 : INC2LX(2,nlx)=ino1 143 : INC2LX(3,nlx)=imot1 144 : 145 : c ajustement de irigel 146 : NRIGEL=NRIGEL+1 147 : segadj,MRIGID 148 : COERIG(NRIGEL) = XCOE1 149 : 150 : c remplissage du maillage (les noeuds) 151 : NBSOUS=0 152 : NBREF=0 153 : NBNN = NBNN1+1 154 : NBELEM=1 155 : segini,MELEME 156 : ITYPEL=22 157 : NUM(1,1)=NBPTS 158 : inono=1 159 : do inode=1,NBNN1 160 : inono=inono+1 161 : NUM(inono,1)=IPT1.NUM(inode,iel1) 162 : enddo 163 : IRIGEL(1,NRIGEL) = MELEME 164 : c segdes,MELEME 165 : 166 : c remplissage du DESCR + XMATRI 167 : c nbre d'inconnues = nbre initial + LX - celles qu'il faut enlever 168 : NLIGRP = NLIGP1+1-nbinc1 169 : NLIGRD = NLIGRP 170 : NELRIG = 1 171 : segini,DESCR,XMATRI 172 : LISINC(1)='LX ' 173 : LISDUA(1)='FLX ' 174 : NOELEP(1)= 1 175 : NOELED(1)= 1 176 : inono=1 177 : c on remplit le terme Ktt relatif au LX 178 : RE(1,1,1) = XMATR1.RE(iinc1,iinc1,iel1) 179 : 180 : do iinc=(nbinc1+1),NLIGP1 181 : inono=inono+1 182 : LISINC(inono)=DES1.LISINC(iinc) 183 : LISDUA(inono)=DES1.LISDUA(iinc) 184 : c rem : on suppose qu'on a en entrée NOELEP = 1 2 1 2 3 4 5 6 185 : c et qu'on tranforme en LX les deux premieres inconnues. 186 : c Pour etre + général il faudrait faire une boucle 187 : c et identifier avec meleme 188 : NOELEP(inono)=1+DES1.NOELEP(iinc) 189 : NOELED(inono)=1+DES1.NOELED(iinc) 190 : jnono=1 191 : RE(inono,jnono,1)=XMATR1.RE(iinc,iinc1,iel1) 192 : RE(jnono,inono,1)=XMATR1.RE(iinc1,iinc,iel1) 193 : jnono=inono-1 194 : do jinc=iinc,NLIGP1 195 : jnono=jnono+1 196 : RE(inono,jnono,1)=XMATR1.RE(iinc,jinc,iel1) 197 : RE(jnono,inono,1)=XMATR1.RE(jinc,iinc,iel1) 198 : cbp : on met a 0, meme si ces termes ne sont que des 0 199 : c ou des 1 sur la diago pour eviter indeterminations.... 200 : XMATR1.RE(iinc,jinc,iel1)=0.d0 201 : XMATR1.RE(jinc,iinc,iel1)=0.d0 202 : enddo 203 : enddo 204 : IRIGEL(3,NRIGEL) = DESCR 205 : IRIGEL(4,NRIGEL) = XMATRI 206 : IRIGEL(5,NRIGEL) = NIFOU1 207 : 208 : GOTO 1021 209 : 210 : 211 : 1022 continue 212 : c -si ce LX existe , il est ajoute au irigel ilx (=nrigel) 213 : MELEME = IRIGEL(1,ilx) 214 : DESCR = IRIGEL(3,ilx) 215 : XMATRI = IRIGEL(4,ilx) 216 : c - y a t-il de nouveau noeud dans le melem ? -> au moins 1 WX de plus ! 217 : 218 : c somme pour le Ktt du LX qui est obligatoirement en commun 219 : RE(1,1,1) = RE(1,1,1) + XMATR1.RE(iinc1,iinc1,iel1) 220 : 221 : c etape 1 : on remplit les tableaux de correspondance primal itoto 222 : c et dual jtoto (matrice RE d'entree -> de sortie) 223 : 224 : c boucle sur les inconnues primales de la matrice en entrée 225 : do 1023 iinc=(nbinc1+1),NLIGP1 226 : itoto(iinc)=0 227 : inoe1 = DES1.NOELEP(iinc) 228 : inum1 = IPT1.NUM(inoe1,iel1) 229 : MOINC1 = DES1.LISINC(iinc) 230 : c on cherche inono = inconnue du nouveau mrigid 231 : c qui a le meme noeud et meme nom d'inconnue 232 : do 1024 inono = 1,NOELEP(/1) 233 : MOINC = LISINC(inono) 234 : if(MOINC.ne.MOINC1) goto 1024 235 : inoe = NOELEP(inono) 236 : inum = NUM(inoe,1) 237 : if(inum.ne.inum1) goto 1024 238 : c cas 1 : cette inconnue primale est partagée 239 : c => on remplit le tableau de correspondance 240 : itoto(iinc)=inono 241 : goto 1023 242 : 1024 continue 243 : c cas 2 : il s'agit d'une nouvelle inconnue primale 244 : c => il faut la créer + on crée aussi la duale 245 : c (en espérant qu'on commence toujours dans le coin en haut a gauche 246 : c et qu'on ne décrit pas des "bouts" de matrice 247 : c = correspondance implicite primale-duale) 248 : NBNN = NUM(/1)+1 249 : segadj,MELEME 250 : NUM(NBNN,1)=inum1 251 : NLIGRP = NOELEP(/1)+1 252 : NLIGRD = NLIGRP 253 : segadj,DESCR,XMATRI 254 : NOELEP(NLIGRP)=NBNN 255 : NOELED(NLIGRD)=NBNN 256 : LISINC(NLIGRP)=MOINC1 257 : LISDUA(NLIGRD)=DES1.LISDUA(iinc) 258 : itoto(iinc)=NLIGRP 259 : 1023 continue 260 : 261 : c etape 2 : on fait la somme sur le triangle superieur et on symétrise 262 : 263 : c boucle sur les inconnues primales de la matrice en entrée 264 : do 1025 iinc=(nbinc1+1),NLIGP1 265 : inono = itoto(iinc) 266 : c boucle sur les inconnues duales de la matrice en entrée 267 : do 1025 jinc=(nbinc1+1),iinc 268 : jnono = itoto(jinc) 269 : RE(jnono,inono,1) = RE(jnono,inono,1) 270 : & + XMATR1.RE(jinc,iinc,iel1) 271 : RE(inono,jnono,1) = RE(jnono,inono,1) 272 : 1025 continue 273 : 274 : 275 : 1021 continue 276 : c-------- fin de boucle sur les inconnues a remplacer ----------------- 277 : 278 : 1020 continue 279 : c------ fin de boucle sur les elements -------------------------------- 280 : 281 : 282 : 1000 CONTINUE 283 : c==== fin de Boucle sur les sous rigidites ======================== 284 : 285 : segadj,MCOORD 286 : 287 : c------------------------------- 288 : c MENAGE AVANT DE QUITTER 289 : c------------------------------- 290 : 291 : segsup,MTRAV 292 : 293 : C on desactive la sortie 294 : do iri=1,IRIGEL(/2) 295 : XMATRI = IRIGEL(4,iri) 296 : DESCR = IRIGEL(3,iri) 297 : MELEME = IRIGEL(1,iri) 298 : segdes,XMATRI,DESCR,MELEME 299 : enddo 300 : c on laisse MRIGID actif 301 : 302 : C on supprime l entree 303 : do iri=1,RI1.IRIGEL(/2) 304 : XMATRI = RI1.IRIGEL(4,iri) 305 : DESCR = RI1.IRIGEL(3,iri) 306 : MELEME = RI1.IRIGEL(1,iri) 307 : if(XMATRI.ne.0) segsup,XMATRI 308 : if(DESCR.ne.0) segsup,DESCR 309 : if(MELEME.ne.0) segsup,MELEME 310 : enddo 311 : segsup,RI1 312 : 313 : RETURN 314 : 315 : END 316 : 317 : 318 : 319 : 320 : 321 : 322 : 323 :
© Cast3M 2003 - All rights reserved.
Disclaimer