1 : C SUPDEP SOURCE PV 10/10/13 21:15:47 6781 2 : SUBROUTINE SUPDEP 3 : c================================================================= 4 : c cette procedure est appelée par SUPER 5 : c A partir du champ de deplacements interface et du champ d efforts 6 : c sur la sous structure, elle determine le champ de déplacement 7 : c sur toute la sous-structure 8 : c================================================================= 9 : IMPLICIT INTEGER(I-N) 10 : IMPLICIT REAL*8(A-H,O-Z) 11 : -INC SMSUPER 12 : -INC SMELEME 13 : -INC CCOPTIO 14 : -INC SMMATRI 15 : -INC SMCHPOI 16 : -INC SMVECTD 17 : -INC SMRIGID 18 : c ???????????????????????????????????????????????????????????????? 19 : SEGMENT/BID/(BIDON(IIMAX+10)*D) 20 : c ???????????????????????????????????????????????????????????????? 21 : c de la meme facon que dans MONDES , on va charger la maximum de 22 : c lignes en memoire pendant que l'on va gerer les efforts 23 : c IPLIG : première ligne en mémoire 24 : c IDLIG : dernière ligne en mémoire 25 : c---------------------------------------------------------------- 26 : PARAMETER (LPCRAY=10000) 27 : segment ITRAA(NENS) 28 : integer OOOVAL 29 : logical leffort 30 : 31 : c creation d'une pile MRU 31 : call OOOMRU(1) 31 : call lirobj('SUPERELE',MSUPER,1,IRETOU) 32 : if (ierr.ne.0) RETURN 33 : c lecture du déplacement interface 33 : call lirobj('CHPOINT ',MDEPI,1,IRETOU) 34 : if (ierr.ne.0) RETURN 35 : c lecture du champ d'efforts si il existe 36 : c 27/11/2009 lecture obligatoire car risque d'erreur utilisateur 37 : c due a une mauvaise comprehension de l'operation 37 : call lirobj('CHPOINT ',MFORC,1,IRETOU) 38 : if (ierr.ne.0) RETURN 39 : if (iretou .eq. 0) then 40 : leffort = .false. 41 : else 42 : leffort = .true. 43 : end if 44 : 45 : segact MSUPER 46 : * write(6,*) MRIGTO,MSUPEL,MSURAI,MBLOQU,MSUMAS,MCROUT 47 : c 48 : c recherche du nombre d'inconnues maitres 49 : MRIGID = MSURAI 50 : segact MRIGID 51 : xMATRI = IRIGEL(4,1) 52 : lagdua=msuper.islag 53 : * write (6,*) ' msurai lagdua dans supdep ', mrigid,lagdua 54 : segdes MRIGID 55 : segact xMATRI 56 : * XMATRI = IMATTT(1) 57 : * segdes IMATRI 58 : * segact XMATRI 59 : nligra = RE(/1) 60 : segdes XMATRI 61 : c 62 : MCROUX = MCROUT 63 : * creation du meleme des noeuds maitres 64 : MRIGID=MRIGTO 65 : SEGACT MRIGID 66 : 67 : meleme=msupel 68 : 69 : MRIGID = MSURAI 70 : c sauvegarde du deplacement interface 70 : call reduir(MDEPI,MELEME,MDEPint) 70 : call adchpo(mdepi,mdepint,mdext,1.d0,-1.d0) 70 : * call ecchpo(mdepi,0) 70 : * call ecchpo(mdepint,0) 71 : * write (6,*) ' mdext ' 71 : * call ecchpo(mdext,0) 72 : c transformation du champ de déplacement en vecteur 72 : * call ecmail(lagdua,0) 72 : ** call dbbch(mdepint,lagdua) 72 : call chv1(MCROUX,MDEPInt,MVECTX,1) 73 : c normalisation 74 : MMATRI = MCROUT 75 : segact MMATRI 76 : MDNOR = IDNORM 77 : segact MDNOR 78 : INC = DNOR(/1) 79 : c inbine : intger nombre inconnues esclaves 80 : 81 : inbine = INC - Nligra 82 : * write (6,*) ' inbine inc nligra ',inbine,inc,nligra 83 : MVECTD = MVECTX 84 : segact MVECTD*mod 85 : do 1 ii1 = inbine+1,INC 86 : VECTBB(ii1) = VECTBB(ii1) / DNOR(ii1) 87 : 1 continue 88 : 89 : MVECT1 = MVECTD 90 : MILIGN = IILIGN 91 : segact MILIGN 92 : NNOE = ILIGN(/1) 93 : 94 : c ????? idem que dans MONDES ?????? 95 : LTRK = MAX(1+LPCRAY,OOOVAL(1,4)) 96 : IIMAX = (((IJMAX+LTRK)/LTRK)+1)*LTRK 97 : c 98 : *********************************************************************** 99 : *********************************************************************** 100 : c pb à résoudre : L1t X + L2t DEPI = D(-1) L1(-1) F 101 : c 102 : * commencons par traiter le terme en effort 103 : c transformation du CHPOINT en vecteur 104 : if (leffort) then 105 : MCHPOI = MFORC 106 : MRIGID = MRIGTO 107 : segdes MRIGID 107 : call copie2(mchpoi,mchpo1) 108 : SEGACT MCHPO1 109 : DO 432 I=1,mchpo1.IPCHP(/1) 110 : MSOUPO=mchpo1.IPCHP(I) 111 : SEGACT MSOUPO*MOD 112 : IPT4=IGEOC 113 : SEGINI,ipt5=ipt4 114 : SEGDES ipt4 115 : IGEOC=ipt5 116 : 432 CONTINUE 116 : call dbbch(mchpo1,lagdua) 116 : * call ecchpo(mchpo1 ,0) 116 : call chv2(MCROUX,MCHPO1,MVECTX,1) 117 : MVECTD = MVECTX 118 : c attention CHV2 desactive tout 119 : segact MMATRI 120 : segact MILIGN 121 : segact MVECTD*MOD 122 : MDIAG = IDIAG 123 : segact MDIAG 124 : c 125 : c il faut normaliser ce vecteur 126 : c on va de plus recuperer l'indice du premier terme non nul 127 : dnorma = 0.D0 128 : inbi=vectbb(/1) 129 : * write (6,*) ' inbine ',inbine 130 : * write (6,*) ' vectbb-1 ',(vectbb(i),i=1,vectbb(/1)) 131 : * write (6,*) ' dnor ',(dnor (i),i=1,vectbb(/1)) 132 : 133 : 134 : do 2 ii1=1,inbine 135 : VECTBB(ii1) = VECTBB(ii1) * DNOR(ii1) 136 : dnorma = max(dnorma,abs(VECTBB(ii1))) 137 : 2 continue 138 : * write (6,*) ' vectbb-2 ',(vectbb(i),i=1,vectbb(/1)) 139 : dnorma = dnorma * 1.D-12 140 : c 141 : c recherche du premier terme non nul 142 : do 3 ii1=1,inbine 143 : if (abs(VECTBB(ii1)).GE.dnorma) GOTO 4 144 : 3 continue 145 : * write(6,*) ' attention vecteur force nulle' 146 : 4 continue 147 : ipremf = ii1 148 : if(dnorma.eq.0.d0) ipremf=max(1,inbine) 149 : 150 : * effectuons maintenant le produit (L1)-1 EFFORT 151 : *------------------------------------------------- 152 : c ???????????? 153 : segini BID 154 : ivalma = 0 155 : c ???????????? 156 : c d'ou le bloc associé 157 : INPREM = IPNO(ipremf) 158 : c et le bloc de la dernière ligne 159 : INDERn=-1 160 : if(inbine.ne.0)INDERN = IPNO(inbine) 161 : 162 : c 163 : IPLIG = INPREM 164 : do 10 ii0=INPREM,INDERN 165 : LIGN = ILIGN(ii0) 166 : segact /ERR=20/ LIGN 167 : IPRELL = IPREL 168 : IVALMA = IVALMA+VAL(/1) 169 : *pvpv if (IVALMA.GT.NGMAXY) GOTO 20 170 : NA = IMMM(/1) 170 : call supde2(IPPVV(1),IVPO(1),VAL(1),VECTBB(1), 171 : > na,inumli,inbine,ipremf,iprel) 172 : 10 continue 173 : segsup BID 174 : IDLIG = INDERN 175 : GOTO 60 176 : c on a eu des problèmes de memoire 177 : 20 continue 178 : SEGSUP BID 179 : IDLIG = ii0 - 1 180 : itemp1 = ii0 181 : c c'est reparti 182 : do 30 ii0=itemp1,INDERN 183 : LIGN = ILIGN(ii0) 184 : segact /ERR=22/ LIGN 185 : NA = IMMM(/1) 186 : IPRELL = IPREL 186 : call supde2(IPPVV(1),IVPO(1),VAL(1),VECTBB(1), 187 : > na,inumli,inbine,ipremf,iprel) 188 : segdes LIGN*(NOMOD,MRU) 189 : GOTO 30 190 : c il y a encore des problèmes 191 : 22 CONTINUE 192 : c il va falloir faire de la place ==> desactivation d'une ligne 193 : c reste-t-il des lignes à desactiver ? 194 : if (IDLIG .lt. IPLIG) then 194 : CALL ERREUR(5) 195 : else 196 : LIGN=ILIGN(IDLIG) 197 : SEGDES LIGN*(NOMOD,MRU) 198 : IDLIG=IDLIG-1 199 : end if 200 : 30 continue 201 : c 202 : c muliplions maintenant par D-1 203 : c--------------------------------- 204 : 60 continue 205 : do 70 i=1,inbine 206 : VECTBB(i) = VECTBB(i) / DIAG(i) 207 : 70 continue 208 : segdes MDIAG 209 : else 210 : c il n y a pas d'efforts 211 : segini MVECTD 212 : c il faut preciser qu il n y a aucune ligne chargée 213 : IDLIG = 0 214 : IPLIG = NNOE 215 : end if 216 : c 217 : c 218 : *********************************************************************** 219 : *********************************************************************** 220 : c Il faut maintenant effectuer le calcul L1t X1 + L2t X2 = Nouveau F 221 : c il ne s'agit que d'une remontée 222 : c 223 : c on va en profiter pour compter les mouvements d'ensemble 224 : iaa = 0 225 : segini itraa 226 : c 227 : c inumli : numero de la ligne en cours 228 : inumli = INC 229 : do 120 ii0=NNOE,1,-1 230 : LIGN = ILIGN(ii0) 231 : 122 continue 232 : if ((ii0.gt.IDLIG).or.(ii0.lt.IPLIG)) then 233 : segact /ERR=124/ LIGN 234 : else 235 : IDLIG = IDLIG - 1 236 : end if 237 : NA = IMMM(/1) 238 : IFIB=IVPO(/1) 238 : call supde1(IPPVV(1),IVPO(1),VAL(1),VECTBB(1), 239 : & MVECT1.VECTBB(1),na,inumli,inbine,iprel,ifib) 240 : do ibb=1,NA 241 : if (IMMM(ibb) .ne. 0) then 242 : iaa = iaa+1 243 : itraa(iaa)=iprel+ibb-1 244 : end if 245 : end do 246 : segdes LIGN*(NOMOD,MRU) 247 : GOTO 120 248 : 124 CONTINUE 249 : c encore des problèmes mémoires 250 : if (IDLIG .lt. IPLIG) then 250 : CALL ERREUR(5) 251 : else 252 : LIG1=ILIGN(IDLIG) 253 : SEGDES LIG1*(NOMOD,MRU) 254 : IDLIG=IDLIG-1 255 : GOTO 122 256 : end if 257 : 120 continue 258 : 259 : segsup MVECTD 260 : MVECTD = MVECT1 261 : c 262 : ******************************************************************************* 263 : ******************************************************************************* 264 : c gestion des déplacements de corps rigide 265 : c meme chose que dans MONDES 266 : c ------ 267 : c 268 : if (nens .ne. 0) then 269 : MINCPO = IINCPO 270 : MIMIK = IIMIK 271 : segact MINCPO,MIMIK 272 : ipt2 = IGEOMA 273 : segact ipt2 274 : NNOE = INCPO(/2) 275 : IINC1=INCPO(/1) 276 : c 277 : XMA = 0. 278 : do kk=1,INC 279 : XMA=MAX(XMA,ABS(VECTBB(kk))) 280 : end do 281 : XMA = XMA * 1.E-10 282 : c boucle sur les mouvements d'ensemble 283 : do 200 ia=1,NENS 284 : i1=itraa(ia) 285 : j=IPNO(i1) 286 : do 210 k=1,iinc1 287 : if(INCPO(K,J).eq.i1) goto 220 288 : 210 continue 288 : call erreur(5) 289 : return 290 : 220 continue 291 : if ((ittr(i1).eq.0).and.(ABS(VECTBB(i1)).le.XMA)) GOTO 250 292 : if ((ittr(i1).ne.0).and.(ABS(VECTBB(i1)).le.XMA*1E7)) GOTO 250 293 : MOTERR(1:4)=IMIK(k) 294 : INTERR(1)=ipt2.NUM(1,J) 294 : CALL ERREUR(149) 295 : RETURN 296 : 250 continue 297 : jjk = ipt2.NUM(1,J) 298 : IF(ITTR(I1).EQ.0) WRITE(IOIMP,280) JJK,IMIK(K) 299 : 300 : IF (IIMPI.NE.0 .AND. ITTR(I1).NE.0) 301 : & WRITE(IOIMP,290) JJK,IMIK(K) 302 : 303 : 200 continue 304 : 280 FORMAT(' INDETERMINATION DETECTEE AU NOEUD ',I6,' INCONNUE ', 305 : * A4,/,' INDETERMINATION LEVEE PAR LA MISE A ZERO DE ', 306 : * 'LA SUSDITE') 307 : 290 FORMAT(' INDETERMINATION ENTRE CONDITIONS IMPOSEES DETECTEE ', 308 : * 'AU NOEUD ',I6,' INCONNUE ',A4,/,' INDETERMINATION LEVEE ', 309 : * 'PAR LA SUPPRESSION DE LA CONDITION REDONDANTE ') 310 : 311 : segdes MINCPO,MIMIK 312 : segdes ipt2 313 : end if 314 : c 315 : ******************************************************************************* 316 : ******************************************************************************* 317 : * un petit coup de normalisation 318 : do 300 ii1=1,INC 319 : VECTBB(ii1) = VECTBB(ii1) * DNOR(ii1) 320 : 300 continue 321 : 322 : segdes MDNOR 323 : segdes MVECTD 324 : MVECTX = MVECTD 325 : MMATRX = MMATRI 326 : MRIGTX = MRIGTO 327 : * write(6,*) ' mrigto mmatri mvectx ', mrigto,mmatri,mvectx 328 : c il faut transformer ce vecteur en chpoint 328 : call VCH1(MMATRX,MVECTX,ISOLU,MRIGTX) 328 : if (lagdua.ne.0) call dbbcf(isolu,lagdua) 329 : ** write (6,*) ' mdext ' 329 : ** call ecchpo(mdext,0) 330 : ** write (6,*) ' isolu ' 330 : ** call ecchpo(isolu,0) 330 : call adchpo(isolu,mdext,mchpoi,1.d0,1.d0) 331 : * mchpoi=isolu 332 : segact MCHPOI*mod 333 : JATTRI(1)=1 334 : segdes MCHPOI 335 : 336 : segdes MMATRI 337 : c il faut maintenant rajouter les déplacements imposés éliminés (jrcond) 338 : MRIGID = MRIGTO 339 : * segact MRIGID 340 : segdes MRIGID 341 : c 342 : segdes MSUPER 343 : c il faut ajuster le type du champ 344 : 345 : c on rajoute les multiplicateurs interfaces 345 : call ecrobj('CHPOINT ',mchpoi) 346 : 347 : c désactivation de la pile MRU 347 : call OOOMRU(0) 348 : return 349 : end 350 : 351 : 352 : 353 : 354 :
© Cast3M 2003 - All rights reserved.
Disclaimer