1 : C RESOU SOURCE CHAT 09/10/09 21:22:54 6519 2 : SUBROUTINE RESOU 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8 (A-H,O-Z) 5 : C 6 : C **** CET OPERATEUR SERT A RESOUDRE UN SYSTEME D EQUATIONS LINEAIRES 7 : C **** CHPOINT = RESOU RIGIDITE CHPOINT 8 : C 9 : C 10 : -INC SMRIGID 11 : -INC SMTEXTE 12 : -INC CCOPTIO 13 : -INC SMTABLE 14 : -INC SMCHPOI 15 : -INC SMELEME 16 : -INC SMLCHPO 17 : SEGMENT IDEMEM(0) 18 : segment ideme0(idemem(/1)) 19 : segment ideme1(idemem(/1)) 20 : segment idnote(0) 21 : C 22 : CHARACTER*4 LISM(5) 23 : CHARACTER*(8) ITCHPO,CHARRE1 24 : CHARACTER*72 CHARRE 25 : REAL*8 XVA 26 : LOGICAL ILOG,ILUG,casfimp 27 : DATA LISM/'NOID','NOUN','ENSE','GRAD','CHOL'/ 28 : DATA ITCHPO/'CHPOINT '/ 29 : DATA ILOG/.FALSE./ 30 : C 31 : iunil=0 32 : IMTVID=0 33 : NOUNIL=0 34 : NOID=0 35 : NOEN=1 36 : IGRADJ = 0 37 : ICHSKI = 0 38 : INSYM = 0 39 : KIKI=0 40 : KSYMET = 0 41 : IPSHPO = 0 42 : 5 CONTINUE 42 : CALL LIRMOT(LISM,5,KIKI,0) 43 : IF (KIKI.EQ.1) NOID=1 44 : IF (KIKI.EQ.2) NOUNIL=1 45 : IF (KIKI.EQ.3) NOEN=0 46 : * IF (KIKI.EQ.4) IGRADJ = 1 47 : * IF (KIKI.EQ.5) ICHSKI = 1 48 : * IF (KIKI.EQ.4.OR.KIKI.EQ.5) KSYMET = 1 49 : IF (KIKI.NE.0) GOTO 5 50 : IF(NUCROU.EQ.0) THEN 51 : ICHSKI=1 52 : ELSEIF(NUCROU.EQ.1) THEN 53 : IGRADJ=1 54 : KSYMET=1 55 : ENDIF 56 : * WRITE(6,*) ' nucrou', nucrou 57 : * IF ( IGRADJ + ICHSKI .EQ. 0 ) ICHSKI = 1 58 : 58 : CALL LIROBJ('RIGIDITE',IPOIRI,1,IRETOU) 59 : IF(IERR.NE.0) GO TO 5000 60 : IPRIGO=IPOIRI 61 : C 62 : PREC=1D-18 62 : CALL LIRREE(PREC,0,IRETOU) 63 : IF(IERR.NE.0) GO TO 5000 64 : SEGINI IDEMEM 65 : 1 CONTINUE 65 : CALL LIROBJ(ITCHPO,ISECO,0,IRETOU) 66 : IF(IRETOU.NE.0) THEN 67 : IDEMEM(**)=ISECO 68 : GO TO 1 69 : ENDIF 70 : 70 : CALL LIRTAB('LIAISONS_STATIQUES',ITBAS,0,IRET) 71 : IF (IRET.EQ.0) THEN 72 : 73 : ENDIF 73 : CALL LIROBJ('LISTCHPO',ISECO,0,IRETOU) 74 : IF(IRETOU.NE.0) THEN 75 : mlchpo=ISECO 76 : segact mlchpo 77 : n1 = ichpoi(/1) 78 : do iu = 1 , n1 79 : idemem(**) = ichpoi(iu) 80 : enddo 81 : segdes mlchpo 82 : segini mlchpo 83 : ipshpo = mlchpo 84 : ENDIF 85 : IF (IERR.NE.0) RETURN 86 : 87 : 88 : IF (ITBAS.NE.0 .AND. IIMPI.EQ.333) THEN 89 : WRITE(IOIMP,*) 'on a lu la table des conditions aux limites' 90 : ENDIF 91 : C------------------------------------------------------ 92 : if (itbas.ne.0) then 93 : mtab1 = itbas 94 : segact mtab1 95 : ima = mtab1.mlotab - 1 96 : segini idnote 97 : im = 0 98 : segdes mtab1 99 : else 100 : goto 90 101 : endif 102 : 103 : * boucle en cas de résolutions successives avec table 104 : 80 continue 105 : im = im + 1 106 : itmod = 0 107 : ichp0 = 0 108 : if (im.gt.ima) then 109 : if (idemem(/1).gt.0) goto 90 110 : * pas de champs de force 110 : call erreur(1) 111 : return 112 : endif 112 : CALL ACCTAB(ITBAS,'ENTIER',IM,0.d0,' ',.true.,IP0, 113 : & 'TABLE',I1,X1,CHARRE,.true.,ITMOD) 114 : if (ierr.ne.0) return 115 : if (itmod.gt.0) then 115 : CALL ACCTAB(ITMOD,'MOT',0,0.d0,'FORCE',.true.,IP0, 116 : & 'CHPOINT',I1,X1,CHARRE,.true.,ICHP0) 117 : if (ierr.ne.0) return 118 : if (ichp0.gt.0) then 119 : idemem(**) = ichp0 120 : idnote(**) = im 121 : else 121 : call erreur(1) 122 : return 123 : endif 124 : endif 125 : goto 80 126 : 127 : IF (IERR.NE.0) RETURN 128 : 90 continue 129 : * verification pas de blocage en double 129 : call verlag(ipoiri) 130 : if (ierr.ne.0) return 131 : * y a t il des matrices de relations non unilaterales 132 : ipoir0 = ipoiri 133 : mrigid=ipoiri 133 : C call prrigi(ipoiri,1) 134 : segact mrigid 135 : nrige= irigel(/1) 136 : idepe=0 137 : nbr = irigel(/2) 138 : do 1000 irig = 1,nbr 139 : meleme=irigel(1,irig) 140 : segact meleme 141 : if ((irigel(6,irig).eq.0.or.nounil.eq.1).and.itypel.eq.22) 142 : > idepe=idepe+1 143 : if (irigel(6,irig).ne.0) iunil=1 144 : segdes meleme 145 : 1000 continue 146 : * idepe=0 147 : lagdua=0 148 : 149 : if(idepe.ne.0) then 150 : C on va separer les raideurs 151 : * write (6,*) ' nounil jrcond vaut ',nounil,jrcond 152 : if (jrcond.eq.0) then 152 : call separm(mrigid,ri1,ri2,nounil,lagdua) 152 : * if (lagdua.ne.0) call ecmail(lagdua) 153 : * write(6,*) ' resou apres separm -- ri2' 153 : * call prrigi(ri2,1) 154 : * write(6,*) ' resou apres separm -- ri1' 154 : * call prrigi ( ri1,1) 155 : * write(6,*) ' fin impression ri1' 156 : segact mrigid*mod 157 : jrelim=ri1 158 : jrgard=ri2 159 : imlag=lagdua 159 : call fusrig(ri1,ri2,ipoir0) 160 : jrtot=ipoir0 161 : else 162 : ri1=jrelim 163 : ri2=jrgard 164 : ipoir0=jrtot 165 : lagdua=imlag 166 : ipt1=lagdua 167 : if (ipt1.ne.0) segact ipt1 168 : endif 169 : iri1s=ri1 170 : iri2s=ri2 171 : C 172 : 1010 continue 173 : C 174 : * mrigid matrice complete 175 : * ri1 dependance 176 : * ri2 les autres matrices 177 : * ri6 matrice de transfert 178 : * ri3 matrice reduite 179 : * ri5 matrice de transfert transposee 180 : C 181 : C on va proceder a la condensation rigidite puis forces 182 : if(jrcond.eq.0) then 183 : 183 : CALL DEPEN3(RI1,RI6) 184 : * write (6,*) ' resou apres depen3 --- ri6 ' 184 : * call prrigi(ri6,1) 184 : call scnd2 (ri2,ri6,ri3) 185 : * write (6,*) ' resou apres scnd2--- ri3 ' 185 : * call prrigi(ri3,1) 186 : segact ri3 187 : if(ierr.ne.0) then 188 : segsup ri1,ri2,ri6,idemem 189 : return 190 : endif 191 : 192 : segact mrigid*mod 193 : jrcond=ri3 194 : JRDEPP=RI6 195 : C dualisation de la (les) matrice(s) de dependance 195 : call dual00(ri6,ri5) 196 : * write(6,*) ' apres dual0 -- ri5' 196 : * call prrigi( ri5,1) 197 : jrdepd=ri5 198 : ipoiri = ri3 199 : else 200 : ipoiri= jrcond 201 : RI6 = JRDEPP 202 : ri5 = jrdepd 203 : endif 204 : * test si ri3 est vide 205 : ri3=jrcond 206 : segact ri3 207 : * write (6,*) ' dans resou ri3.irigel(/2) ',ri3.irigel(/2) 208 : if (ri3.irigel(/2).eq.0) imtvid=1 209 : C 210 : segdes ri1,ri2,mrigid 211 : C maintenant les seconds membres 212 : C write(6,*) ' ipoiri jrdepp jrdepd',ipoiri,ri6,ri5 212 : C call prrigi(ri3) 213 : 214 : segact idemem*mod 215 : segini ideme0,ideme1 216 : 216 : C call prrigi(ri5) 217 : * en cas de contacts on ne dualise pas . Ce sera fait dans unilater 218 : ifrot=0 219 : MRIGID=IPOIRI 220 : SEGACT MRIGID*MOD 221 : DO I=1,IRIGEL(/2) 222 : IF(IRIGEL(6,I).ne.0) ifrot=1 223 : enddo 224 : if (nounil.eq.1) ifrot=0 225 : * if (ifrot.eq.0) write (6,*) ' resou non unilateral ' 226 : * if (ifrot.eq.1) write (6,*) ' resou unilateral pas de dualisation' 227 : if (lagdua.ne.0) then 228 : ipt8=lagdua 229 : segact ipt8 229 : * call ecmail(lagdua,0) 230 : endif 231 : do 1050 ig=1,idemem(/1) 232 : ichp2= idemem(ig) 233 : ideme0(ig)=ichp2 234 : * transferer les valeurs imposees des relations sur les inconnues (à éliminer) 235 : * write (6,*) ' valeurs imposees ichp2' 235 : * call ecchpo(ichp2,0) 235 : call transr(ichp2,ri1,ichp3) 235 : * call prrigi(ri1) 236 : * write (6,*) ' apres transfert ichp3' 236 : * call ecchpo(ichp3,0) 237 : ideme1(ig)=ichp3 237 : call mucpri(ichp3,ri2,ichp4) 238 : * write (6,*) ' apres mucpri ichp4 ' 238 : * call ecchpo(ichp4,0) 239 : * ri2 est deja dualise. Il faut donc dedualiser ichp4 239 : call dbbcd(ichp4,lagdua) 240 : * write (6,*) ' apres dbbcd ichp4 ' 240 : * call ecchpo(ichp4,0) 240 : call adchpo(ichp2,ichp4,ichp1,1.D0,-1.0D0) 240 : call dtchpo(ichp4) 241 : * write (6,*) ' apres adchpo ichp1' 241 : * call ecchpo(ichp1,0) 241 : call mucpri(ichp1,ri5,ichp2) 242 : * write (6,*) ' impression de ri5 ' 242 : * call prrigi(ri5,1) 243 : * write (6,*) ' apres mucpri ichp2' 243 : * call ecchpo(ichp2,0) 244 : mchpo1=ichp1 245 : C segact mchpo1 246 : C write(6,*) 'reso mchpo1 jattri(1)',mchpo1.jattri(1) 247 : C segdes mchpo1 248 : C 249 : mchpo2= ichp1 250 : segact mchpo2*mod 251 : mchpo2.jattri(1)=2 252 : mchpo2= ichp2 253 : segact mchpo2*mod 254 : mchpo2.jattri(1)=2 255 : C write(6,*) 'reso mchpo2 jattri(1)',mchpo2.jattri(1) 256 : segdes mchpo2 257 : C 257 : call fuchpo (ichp1,ichp2,ichp3) 257 : * call dtchpo(ichp1) 257 : call dtchpo(ichp2) 258 : idemem(ig)=ichp3 259 : * vecteur a resoudre 260 : * write (6,*) ' le vecteur ' 260 : * call ecchpo(ichp3) 261 : * dualisation des mult de lagrange 261 : if (lagdua.ne.0.and.ifrot.eq.0) call dbbch(ichp3,lagdua) 262 : * matrice 263 : * write (6,*) ' la matrice ' 263 : * call prrigi(ipoiri) 264 : 1050 continue 265 : noid = 1 266 : endif 267 : 1060 continue 268 : C------------------------------------------------------- 269 : 270 : * 271 : * Si au moins une des matrices n'est pas symétrique, on passera 272 : * par le solveur non-symétrique LDMT. 273 : * 274 : MRIGID=IPOIRI 275 : SEGACT MRIGID*MOD 276 : NRG = IRIGEL(/1) 277 : NBR = IRIGEL(/2) 278 : C ... Ceci peut arriver si par exemple on extrait la partie 279 : C symétrique d'une matrice purement antisymétrique ... 280 : * IF(NBR.EQ.0) THEN 281 : * SEGDES MRIGID 281 : * CALL ERREUR(727) 282 : * RETURN 283 : * ENDIF 284 : C ... Mais avant on va tester si la normalisation des variables 285 : C primales et duales a été demandée - ceci entraîne la perte 286 : C de la symétrie ... 287 : IF(NORINC.GT.0 .AND. NORIND.GT.0) THEN 288 : IF(KSYMET.EQ.1) THEN 288 : CALL ERREUR(19) 289 : SEGDES,MRIGID 290 : RETURN 291 : ENDIF 292 : INSYM = 1 293 : IGRADJ = 0 294 : ICHSKI = 0 295 : GOTO 15 296 : ENDIF 297 : 298 : IF (NRG.GE.7) THEN 299 : C ... On teste si la matrice contient des matrices non symétriques ... 300 : C ... Si OUI, ce n'est pas la peine de faire les autres tests ... 301 : DO 9 IN = 1,NBR 302 : IANTI=IRIGEL(7,IN) 303 : IF(IANTI.GT.0) THEN 304 : C ... On vérifie si l'utilisateur n'a pas demandé explicitement 305 : C la résolution par Choleski ou gradient conjugué, 306 : C si OUI on râle puis on s'en va !!! ... 307 : IF(KSYMET.EQ.1) THEN 307 : CALL ERREUR(19) 308 : SEGDES,MRIGID 309 : RETURN 310 : ENDIF 311 : IF(NORINC.NE.0.AND.NORIND.EQ.0) THEN 311 : CALL ERREUR(760) 312 : SEGDES,MRIGID 313 : RETURN 314 : ENDIF 315 : INSYM = 1 316 : IGRADJ = 0 317 : ICHSKI = 0 318 : GOTO 15 319 : ENDIF 320 : 9 CONTINUE 321 : 322 : 323 : ENDIF 324 : 325 : 15 CONTINUE 326 : C 327 : C **** ON S'ASSURE QU'IL N'Y A PAS D'APPUIS UNILATERAUX 328 : C 329 : if (iunil.eq.0) goto 30 330 : IF(IRIGEL(/1).LT.6) GO TO 30 331 : IF (NOUNIL.EQ.1) GOTO 30 332 : 21 CONTINUE 333 : C 334 : C **** EXISTENCE DES APPUIS UNILATERAUX 335 : C **** SI ON EST DEJA PASSE DANS LES APPUIS UNILATERAUX 336 : C ISUPEQ POINTE SUR UNE TABLE CONTENANT LES DONNEES A PASSER 337 : C A LA PROCEDURE UNILATER 338 : C 339 : ISUPLO=ISUPEQ 340 : IF (ISUPLO.NE.0) GOTO 27 341 : NNOR=0 342 : DO 22 I=1,IRIGEL(/2) 343 : IF(IRIGEL(6,I).EQ.0) NNOR=NNOR+1 344 : 22 CONTINUE 345 : IF(NNOR.EQ.0) THEN 345 : CALL ERREUR(312) 346 : RETURN 347 : ENDIF 348 : NRIGE=IRIGEL(/1) 349 : NRIGEL=NNOR 350 : SEGINI RI1 351 : NRIGEL=IRIGEL(/2)-NNOR 352 : SEGINI RI2 353 : II1=0 354 : II2=0 355 : DO 23 I=1,IRIGEL(/2) 356 : IF(IRIGEL(6,I).NE.0) THEN 357 : RI3=RI2 358 : II2=II2+1 359 : II=II2 360 : ELSE 361 : RI3=RI1 362 : II1=II1+1 363 : II=II1 364 : ENDIF 365 : DO 24 J=1,NRIGE 366 : RI3.IRIGEL(J,II) = IRIGEL(J,I) 367 : 24 CONTINUE 368 : RI3.COERIG(II)=COERIG(I) 369 : 23 CONTINUE 370 : * RI1 raideur sans condition unilaterale 371 : * RI2 conditions unilaterales 371 : CALL CRTABL(MTABLE) 372 : ISUPEQ=MTABLE 373 : * il faut aussi mettre isupeq dans la raideur initiale 374 : MRIGID=IPRIGO 375 : SEGACT MRIGID*MOD 376 : ISUPEQ=MTABLE 377 : if (idepe.ne.0) then 378 : * il faut extraire de la matrice initiale (ipoir0) les conditions unilaterales 379 : mrigid=iri2s 380 : segact mrigid 381 : nrigel=0 382 : do 40 i=1,irigel(/2) 383 : if (irigel(6,i).eq.0) nrigel=nrigel+1 384 : 40 continue 384 : if (nrigel.eq.0) call erreur(312) 385 : if (ierr.ne.0) return 386 : nrige=irigel(/1) 387 : segini ri4 388 : ii1=0 389 : nrigel=irigel(/2)-nrigel 390 : segini ri5 391 : ii2=0 392 : do 41 i=1,irigel(/2) 393 : if (irigel(6,i).ne.0) goto 42 394 : ii1=ii1+1 395 : do j=1,nrige 396 : ri4.irigel(j,ii1)=irigel(j,i) 397 : enddo 398 : ri4.coerig(ii1)=coerig(i) 399 : goto 41 400 : 42 continue 401 : ii2=ii2+1 402 : do j=1,nrige 403 : ri5.irigel(j,ii2)=irigel(j,i) 404 : enddo 405 : ri5.coerig(ii2)=coerig(i) 406 : 41 continue 407 : segdes mrigid,ri4 408 : endif 408 : CALL ECCTAB(MTABLE,'ENTIER ',1,XVA,' ',ILOG,IOB, 409 : $ 'RIGIDITE',IOB,XVA,' ',ILOG,RI1) 409 : CALL ECCTAB(MTABLE,'ENTIER ',2,XVA,' ',ILOG,IOB, 410 : $ 'RIGIDITE',IOB,XVA,' ',ILOG,RI2) 410 : CALL ECCTAB(MTABLE,'ENTIER ',3,XVA,' ',ILOG,IOB, 411 : $ 'LOGIQUE ',IOB,XVA,' ',ILOG,IOB) 412 : if(idepe.ne.0) then 412 : CALL ECCTAB(MTABLE,'ENTIER ',8,XVA,' ',ILOG,IOB, 413 : $ 'RIGIDITE',IOB,XVA,' ',ILOG,iri1s) 413 : CALL ECCTAB(MTABLE,'ENTIER ',9,XVA,' ',ILOG,IOB, 414 : $ 'RIGIDITE',IOB,XVA,' ',ILOG,ri4 ) 414 : CALL ECCTAB(MTABLE,'ENTIER ',12,XVA,' ',ILOG,IOB, 415 : $ 'RIGIDITE',IOB,XVA,' ',ILOG,ri5 ) 416 : endif 417 : if (lagdua.ne.0) 417 : > CALL ECCTAB(MTABLE,'ENTIER ',13,XVA,' ',ILOG,IOB, 418 : $ 'MAILLAGE',IOB,XVA,' ',ILOG,lagdua) 419 : ISUPLO=MTABLE 420 : SEGDES RI1,RI2,MTABLE 421 : 27 CONTINUE 422 : MTABLE=ISUPLO 423 : SEGACT MTABLE 424 : IF(INSYM.EQ.1) THEN 425 : ILUG=.TRUE. 426 : ELSE 427 : ILUG=.FALSE. 428 : ENDIF 428 : CALL ECCTAB(MTABLE,'MOT ',4,XVA,'NSYM',ILOG,IOB, 429 : $ 'LOGIQUE ',IOB,XVA,' ',ILUG,IOB) 430 : if(idepe.ne.0) then 431 : ichp3=ideme0(1) 431 : * call copie2(ich,ichp3) 431 : CALL ECCTAB(MTABLE,'ENTIER ',10,XVA,' ',ILOG,IOB, 432 : $ 'CHPOINT ',IOB,XVA,' ',ILOG,ichp3) 433 : ichp3=ideme1(1) 433 : * call copie2(ich,ichp3) 433 : CALL ECCTAB(MTABLE,'ENTIER ',11,XVA,' ',ILOG,IOB, 434 : $ 'CHPOINT ',IOB,XVA,' ',ILOG,ichp3) 435 : endif 436 : SEGDES MRIGID 437 : DO 26 I=IDEMEM(/1),1,-1 438 : ISECO=IDEMEM(I) 438 : CALL ECROBJ (ITCHPO,ISECO ) 439 : 26 CONTINUE 440 : SEGSUP IDEMEM 440 : CALL ECROBJ ('TABLE ',ISUPLO) 441 : SEGINI MTEXTE 442 : LTT=8 443 : MTEXT(1:LTT) ='UNILATER' 444 : NCART=8 445 : SEGDES MTEXTE 445 : CALL ECROBJ('TEXTE',MTEXTE) 446 : mrigid=iprigo 447 : segdes mrigid 448 : RETURN 449 : 450 : C ... On arrive ici dans le cas où il n'y a pas d'appuis unilatéraux ... 451 : 30 CONTINUE 452 : * il se peut que le dernier chp soit du frottement 453 : * on l'enleve car il ne sert a rien si on n'appele pas unilater 454 : if (idemem(/1).gt.1.and.idepe.ne.0) then 455 : mchpoi=ideme0(idemem(/1)) 456 : segact MCHPOI 457 : if (mtypoi.eq.'LX ') idemem(/1)=idemem(/1)-1 458 : endif 459 : * frottement 460 : SEGDES IDEMEM 461 : * write(6,*) ' ichski, igradj,insym ',ichski, igradj,insym 462 : * write (6,*) ' imtvid ',imtvid 463 : if (imtvid.eq.1) then 464 : * matrice vide 465 : nsoupo=0 466 : nat=0 467 : segact idemem*mod 468 : do i=1,idemem(/1) 469 : segini mchpoi 470 : idemem(i)=mchpoi 471 : enddo 472 : if (noen.eq.0) then 472 : call ecrent(0) 473 : nbelem=0 474 : nbnn=1 475 : nbsous=0 476 : nbref=0 477 : segini ipt8 478 : ipt8.itypel=1 478 : call ecrobj('MAILLAGE',ipt8) 479 : endif 480 : else 481 : * write(6,*) ' appel resou1 -- idemem(1)' 482 : * segact idemem 483 : * idesec= idemem(1) 483 : * call ecchpo(idesec,0) 484 : * write(6,*) ' appel resou1 -- ipoiri' 484 : * call prrigi ( ipoiri,1) 485 : * write(6,*) ' ichski insym ', ichski, insym 485 : IF(ICHSKI.EQ.1) CALL RESOU1(IPOIRI,IDEMEM,NOID,NOEN,PREC) 485 : IF(IGRADJ.EQ.1) CALL GRACO0(IPOIRI,IDEMEM,NOID,NOEN) 485 : IF(INSYM .EQ.1) CALL LDMT (IPOIRI,IDEMEM,NOID,NOEN,PREC) 486 : IF(IERR.NE.0) GO TO 5001 487 : endif 488 : C 489 : SEGACT IDEMEM 490 : N=IDEMEM(/1) 491 : DO 3 I=1,N 492 : IRET=IDEMEM(N+1-I) 493 : * 494 : MCHPOI= IRET 495 : C----------------------- 496 : if(idepe.ne.0) then 497 : * reintroduction des inconnues supprimees 497 : call mucpri(mchpoi,ri6,ichp3) 498 : * write (6,*) ' resou - mchpoi ' 498 : * call ecchpo(mchpoi,0) 499 : * write (6,*) ' resou - ichp3' 499 : * call ecchpo(ichp3 ,0) 500 : * write (6,*) ' resou - ri6' 500 : * call prrigi(ri6,1) 500 : call adchpo(mchpoi,ichp3,ichp2,1.D0,1.D0) 501 : mchpo1=ideme1(N+1-I) 502 : * write (6,*) ' resou - iret ' 502 : call adchpo(ichp2,mchpo1,iret,1.D0,1D0) 502 : * call ecchpo(mchpoi) 502 : * call ecchpo(iret) 502 : call dtchpo(mchpoi) 502 : call dtchpo(ichp3) 502 : call dtchpo(ichp2) 503 : mchpo1=iret 504 : segact mchpo1*mod 505 : mchpo1.jattri(1)=1 506 : C ------------- deplacements complets puis KU 506 : call mucpri(mchpo1,ri2 ,ichp5) 507 : * write (6,*) ' apres mucpri ' 507 : * call ecchpo(ichp5,0) 508 : mchpo4=ichp5 509 : segact mchpo4*mod 510 : mchpo4.jattri(1)=1 511 : segdes mchpo4 512 : ichp6= ideme0(N+1-I) 513 : C ------- write(6,*) ' --------- KU - F ' 514 : * write (6,*) ' avant adchpo ichp5 ' 514 : * call ecchpo(ichp5) 514 : call adchpo(ichp5,ichp6,IRET,1D0,-1D0) 514 : call dtchpo(ichp5) 515 : * write (6,*) ' apres adchpo ' 515 : * call ecchpo(iret) 515 : call remplx(ri1,iret,ichp7) 516 : if (noen.eq.0) then 516 : call lirobj('MAILLAGE',ipt8,1,iretou) 517 : segact ipt8 517 : call lirent(nben,1,iretou) 518 : endif 518 : call verlx(ri2,iret,mchpo1,noen,ipt8) 519 : if (noen.eq.0) then 519 : call ecrobj('MAILLAGE',ipt8) 520 : nben=ipt8.num(/2) 520 : call ecrent(nben) 521 : endif 521 : call dtchpo(iret) 522 : * write (6,*) ' apres remplx ichp7 ' 522 : * call ecchpo(ichp7,0) 522 : call fuchpo(mchpo1,ichp7,iret) 523 : mchpoi=iret 524 : * supression des multiplicateurs dédoublés 525 : if (lagdua.ne.0) then 525 : call dbbcf(mchpoi,lagdua) 526 : ipt1=lagdua 527 : segdes ipt1 528 : endif 529 : endif 530 : * les champs de points qui sortent sont de nature diffuse 531 : SEGACT MCHPOI 532 : NAT = MAX(1,JATTRI(/1)) 533 : NSOUPO=IPCHP(/1) 534 : SEGADJ MCHPOI 535 : JATTRI(1)=1 536 : SEGDES MCHPOI 537 : IRET = MCHPOI 538 : * 539 : if (itbas.ne.0) then 540 : il = n + 1 - i 541 : ilo = idnote(il) 541 : CALL ACCTAB(ITBAS,'ENTIER',ILO,0.d0,' ',.true.,IP0, 542 : & 'TABLE',I1,X1,CHARRE,.true.,ITMOD) 543 : if (ierr.ne.0) return 543 : CALL CREPO1 (ZERO, ZERO, ZERO, IPOIN) 543 : CALL ECCTAB(ITMOD,'MOT',0,0.0D0,'POINT_REPERE',.TRUE.,0, 544 : & 'POINT',0,0.0D0,' ',.TRUE.,IPOIN) 545 : 545 : CALL ECCTAB(ITMOD,'MOT',0,0.D0,'DEFORMEE', 546 : & .TRUE.,0,'CHPOINT',0,0.D0,' ',.TRUE.,MCHPOI) 547 : 548 : else if (ipshpo.gt.0) then 549 : mlchpo = ipshpo 550 : ichpoi(N+1-I) = iret 551 : else 551 : CALL ECROBJ (ITCHPO,IRET) 552 : endif 553 : 554 : 3 CONTINUE 555 : 5001 CONTINUE 556 : if (itbas.ne.0) then 557 : segdes mtab1 558 : segsup idnote 558 : CALL ECROBJ ('TABLE ',itbas) 559 : endif 560 : 561 : if (ipshpo.gt.0) then 562 : mlchpo = ipshpo 563 : segdes mlchpo 563 : CALL ECROBJ ('LISTCHPO ',ipshpo) 564 : endif 565 : SEGSUP IDEMEM 566 : C 567 : 5000 CONTINUE 568 : RETURN 569 : END 570 : 571 : 572 : 573 : 574 : 575 : 576 : 577 :
© Cast3M 2003 - All rights reserved.
Disclaimer