Numérotation des lignes :

fusebo
C FUSEBO    SOURCE    CB215821  19/08/20    21:17:59     10287           C    CE SOUS-PROGRAMME L'OPERATION "ET" SUR UN maillage pas beauC   ( qui ne respecte pas la partition par type)pour le rendre beau.C   On ne s'occupe pas des referencesC    IPT1:  en entree  IPT3:  en sortieC      SUBROUTINE FUSEBO(IPT1,IPT3)      IMPLICIT INTEGER(I-N) -INC PPARAM-INC CCOPTIO-INC CCGEOME-INC SMELEME      SEGMENT ISO1(NBSOU1)      SEGMENT ISO2(NBSOU1)      segment iso3(nbsou1)      SEGACT IPT1      NBSOU1= IPT1.LISOUS(/1)*      write(6,*) ' entree dans fusebo  nbsou1 ' , nbsou1      segact ipt1      SEGINI ISO1,ISO2,iso3      DO 350 I=1,NBSOU1 350  ISO1(I)=IPT1.LISOUS(I)      ity=0      nbref=0      nbsous=0      DO 310 I1=1,NBSOU1      IPT1=ISO1(I1)      if(IPT1.EQ.0) go to 310      ity = 1 + ity      ias = 1      iso3(ias)=ipt1      segact ipt1      nbnn = ipt1.num(/1)      nbelem = ipt1.num(/2)      do 330 i2 = i1+1, nbsou1      IPT2=ISO1(I2)      IF (IPT2.EQ.0) GOTO 330      IPT2=ISO1(I2)      IF (IPT2.EQ.0) GOTO 330      SEGACT IPT2      IF (IPT1.ITYPEL.NE.IPT2.ITYPEL) GOTO 340      IF (IPT1.NUM(/1).NE.IPT2.NUM(/1)) GOTO 340      ias = ias+1      iso3(ias)= ipt2      iso1(i2)=0      nbelem = nbelem + ipt2.num(/2)  340 continue  330 continue      if(ias.eq.1) then        iso2(ity) = ipt1      else        segini meleme        idec=0        itypel = ipt1.itypel        DO 311 I2=1,ias          IPT1=ISO3(I2)          segact ipt1          do 351 nbe=1,ipt1.num(/2)          do 352 nbn=1,nbnn            num(nbn,idec+nbe)=ipt1.num(nbn,nbe)  352     continue  351     continue         do 353 nbe=1,ipt1.num(/2)  353    icolor(idec+nbe)=ipt1.icolor(nbe)          idec = idec + ipt1.num(/2)  311   continue        iso2(ity)=meleme      endif 310  CONTINUE      if( ity.eq.1) then        ipt3 = iso2(1)      else        NBREF=0        NBNN=0        NBELEM=0        nbsous = ity        SEGINI IPT3        DO 111 I=1,NBSOUs        IPT3.LISOUS(I)=ISO2(I) 111    CONTINUE      endif      SEGSUP ISO1,ISO2,iso3 1020 RETURN      END   

© Cast3M 2003 - Tous droits réservés.
Mentions légales