C TASSPO    SOURCE    PV        12/12/06    21:15:33     7594           
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)
      IMPLICIT INTEGER(I-N)
-INC CCOPTIO                                                             
-INC CCGEOME
-INC CCNOYAU                                                             
-INC SMCOORD                                                             
-INC SMELEME
-INC CCASSIS
      SEGMENT ITLAC(0)  
      CHARACTER*2 CARBID                                                 
      SEGMENT ICPR(XCOOR(/1)/(IDIM+1))                                   
      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                                                           
      DO 1 I=1,ICPR(/1)                                                  
   1  ICPR(I)=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
            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)
*     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