Sources Esope | Cast3M

examel
C EXAMEL    SOURCE    PV        21/01/21    21:15:17     10862          
      SUBROUTINE EXAMEL (ICOLAC,ITLACC,M1,M2,IIICHA)
C----------------------------------------------------------------------
C
C  BUT:  REMPLIT LES PILES A PARTIR DE L EXAMEN DE LA PILE
C        SI IIICHA =1 ON  CHANGE  LES POINTEURS----
C
C     ENTREE ITLACC POINTEUR DE LA PILE EXAMINEE
C            ICOLAC POINTEUR SUR LE CHAPEAU DES PILES
C            M1     @REMIER INDICE D EXAMEN DANS LA PILE
C            M2     DERNIER INDICE
C            IIICHA =1 ON CHANGE LES POINTEURS
C----------------------------------------------------------------
C   APPELE PAR EXPIL
C   APPELLE AJOUN
C
C=======================================================================
C  TABLEAU KCOLA :
C    1  MELEME  2 CHPOIN  3 MRIGID  4 MCHAFF  5 MCHELM  6
C    7          8 MSOLUT  9 MSTRUC 10        11 MAFFEC 12 MSOSTU
C   13  IMATRI 14 MJONCT 15 MATTAC 16 MMATRI 17 MDEFOR 18 MLREEL
C   19  MLENTI 20 MCHARG 21 MODELE 22 MEVOLL 23 MSUPER
C=======================================================================
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
      logical ooovp1
-INC SMELEME
 
-INC PPARAM
-INC CCOPTIO
-INC TMCOLAC
-INC SMCOORD
-INC CCGEOME
      SEGMENT ICPR(nbpts)
      integer ooolen
      iun=1
      ICO1=KCOLA(1)
      ICO2=KCOLA(32)
      ILISSE=ILISSG
      SEGACT ILISSE*MOD
      ITLAC1=ICO2
      icpchg=0
      SEGINI ICPR
      IFAIT = ITLAC1.ITLAC(/1)
      DO 710 IHU=1,IFAIT
      IAM=ITLAC1.ITLAC(IHU)
      ICPR(IAM)=IHU
      if(iam.ne.ihu) icpchg=1
  710 CONTINUE
*  mise a jour de ilgni a ne faire qu'une fois
      if (m1.eq.1.and.iiicha.eq.1)  then
        if (ilgni.ne.0) then
          if (icpr(ilgni).eq.0) then
           IFAIT = IFAIT + 1
           ICPR(ilgni)=IFAIT
           if(ilgni.ne.ifait) icpchg=1
          ENDIF
          ilgni = icpr(ilgni)
        endif
      endif
      DO 601 IEL=M1,M2
      MELEME=ITLAC(IEL)
C     WRITE (IOIMP,8876) MELEME
      IF (MELEME.EQ.0) GO TO  601
      if (.NOT.ooovp1(meleme)) goto 610
C8876 FORMAT(' MELEME',I6)
      if(IIICHA.EQ.1) then
Cgf      activation en mod pour pouvoir renumeroter les maillages
         SEGACT MELEME*MOD
      else
Cgf      On ne fait que lire le maillage, pas besoin de l'ouvrir en
C        ecriture
         SEGACT MELEME
      endif
      IF(LISOUS(/1).EQ.0) GO TO 602
      IF (LISOUS(/1).LT.0) GOTO 610
      DO 603 I=1,LISOUS(/1)
      IVA=LISOUS(I)
      if (IIICHA.EQ.1.AND..NOT.ooovp1(iva)) goto 610
      CALL AJOUN(ICO1,IVA,ILISSE,iun)
      IF(IIICHA.EQ.1)LISOUS(I)=IVA
 603  CONTINUE
 602  CONTINUE
      IF(LISREF(/1).EQ.0) GO TO 645
      IF (LISREF(/1).GT.1000) GOTO 610
      IF (LISREF(/1).LT.0) GOTO 610
      DO 646 I=1,LISREF(/1)
      IVA=LISREF(I)
      if (IIICHA.EQ.1.AND..NOT.ooovp1(iva)) goto 610
      CALL AJOUN(ICO1,IVA,ILISSE,iun)
      IF(IIICHA.EQ.1)LISREF(I)=IVA
 646  CONTINUE
 645  CONTINUE
      IF(NUM(/2).EQ.0) GO TO 660
      if(ifait.eq.nbpts.and.icpchg.eq.0) goto 660
      DO  K2=1,NUM(/2)
      DO  K1=1,NUM(/1)
      IVA=NUM(K1,K2)
      if (iva.gt.icpr(/1).or.iva.le.0)  goto 610
      IF(ICPR(IVA).EQ.0) THEN
        IFAIT = IFAIT + 1
        ICPR(IVA)=IFAIT
        if(iva.ne.ifait) icpchg=1
*        ITLAC1.ITLAC(**)= IVA
*      CALL AJOUN(ICO2,IVA,)
      ENDIF
          IF(IIICHA.EQ.1.and.icpr(iva).ne.iva) NUM(K1,K2)=ICPR(IVA)
      enddo
      enddo
  660 CONTINUE
*  on ne desactive que si le segment n'est pas trop grand pour ne pas
*  provoquer d'appel systematique au menage automatique
      if (ooolen(meleme).lt.10000000) then
        SEGDES MELEME
      else
        segact meleme
      endif
      GOTO 601
 610  continue
*  meleme invalide. On le supprime de la pile
       moterr(1:8)='MAILLAGE'
       interr(1)=itlac(iel)
       call erreur(861)
       itlac(iel)=0
 601  CONTINUE
C# MC      IF(IICHA.NE.1) CALL ITLACT (ICPR,ITLAC1,IFAIT)
      IF(IIICHA.NE.1) CALL ITLACT (ICPR,ITLAC1,IFAIT,ILISSE)
      SEGSUP ICPR
*      SEGDES ILISSE
      RETURN
C     ************
      END