Sources Esope | Cast3M

tasspo
C TASSPO    SOURCE    PV        22/01/10    21:15:05     11258          
C   CE SOUS PROGRAMME A POUR DESSEIN D'ELIMINER DE LA MEMOIRE LES POINTS
C   NE POUVANT PLUS ETRE UTILISES.
C
      SUBROUTINE TASSPO(ITLAC,ICOLAC,MELEME,mena,idonn)
      IMPLICIT INTEGER(I-N)
 
-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
-INC CCNOYAU
-INC SMCOORD
-INC SMELEME
-INC CCASSIS
      SEGMENT ITLAC(0)
      CHARACTER*2 CARBID
      SEGMENT ICPR(nbpts)
      IF (LMNNOM.EQ.0) RETURN
*  nomlu est manipule par tassp2 via repert et ecpi
*     NOMLUS=NOMLU
*  POUR ETRE SUR QU'IL Y A UN ELEMENT DANS ITLAC
      if(nbesc.ne.0) segact ipiloc
      DO 30 I=1,LMNNOM
      IF (INOOB2(I).NE.'MAILLAGE') GOTO 30
      IP=INOOB1(I)
      IDEBCH=IPCHAR(IP)
      IFINCH=IPCHAR(IP+1)-1
      IF (ICHARA(IDEBCH:IFINCH).EQ.' ') GOTO 30
      MELEME=IOUEP2(I)
       IF (MELEME.EQ.0) GOTO 30
       SEGACT MELEME
       if (itypel.eq.22) goto 30
       IF( LISOUS(/1).EQ.0.AND.NUM(/2).EQ.0) go to 30
      CALL AJOU(ITLAC,MELEME)
      GOTO 31
  30  CONTINUE
  31  CONTINUE
      if(nbesc.ne.0) SEGDES,IPILOC
      segact mcoord
      SEGINI ICPR
      ICDOUR=0
      if (itlac(/1).ne.0) THEN
       i1=0
         do iv=1,itlac(/1)
         IVAL=ITLAC(iv)
*SG Conformément à ce qui est fait dans assem1 et asns1, il
*SG faut créer un MELEME identique à IVAL dont le premier LISOUS
*SG est un point quelconque (non multiplicateur de Lagrange)
*SG de IVAL
         ipt1=ival
         ipt3=ipt1
         segact ipt1
         nbsou1=max(1,ipt1.lisous(/1))
         do isou=1,nbsou1
            if (ipt1.lisous(/1).ne.0) ipt3=ipt1.lisous(isou)
            segact ipt3
**          if (ipt3.itypel.ne.22.AND.ipt3.num(/2).ne.0) then
**             i1=ipt3.num(1,1)
**             goto 4865
**          elseif (ipt3.itypel.eq.22.AND.
            if
     >        (ipt3.num(/2).ge.1.and.ipt3.num(/1).ge.1) then
               i1=ipt3.num(1,1)
               goto 4865
            endif
         enddo
         enddo
 4865    continue
         if (i1.EQ.0) call erreur(5)
         nbsous=0
         nbnn=1
         nbref=0
         nbelem=1
         segini meleme
         itypel=1
         num(1,1)=i1
         segdes meleme
         imelp=meleme
         nbsous=nbsou1+1
         nbref=0
         nbnn=0
         nbelem=0
         segini meleme
         lisous(1)=imelp
         ipt3=ipt1
         do isou=1,nbsou1
            if (ipt1.lisous(/1).ne.0) ipt3=ipt1.lisous(isou)
            lisous(isou+1)=ipt3
            segdes ipt3
         enddo
         segdes meleme
         ival=meleme
         CALL NUMOPT(IVAL,ICPR,ICDOUR)
      ELSE
* lecture de noop qui est systematiquement mis par menage
         call lircha(carbid,0,iretou)
         if(iretou.eq.0) write(6,*) ' erreur inattendu tasspo'
      ENDIF
      CALL TASSP2(ITLAC,ICPR,ICDOUR,icolac,mena,idonn)
*     NOMLU=NOMLUS
* creation du maillage resultat
      nbnn=1
      nbelem=icpr(/1)
      nbref=0
      nbsous=0
      segini meleme
      ipt=0
      do 100 ip=1,nbelem
      icp=icpr(ip)
      if (icp.ne.0) then
       ipt=ipt+1
       num(1,ipt)=icp
       icolor(ipt)=idcoul
      endif
 100  continue
      nbelem=ipt
      segadj meleme
      itypel=1
      segsup icpr
      RETURN
      END