Sources Esope | Cast3M

exarig
C EXARIG    SOURCE    OF166741  24/12/18    21:15:07     12089          
 
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 PILE EXAMINEE
C            ICOLAC POINTEURS DES PILES A REMPLIR
C            M1     PREMIER 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  TABLEAU KCOLA : VOIR SOUSPROGRAMME TYPFIL
C=======================================================================
 
      SUBROUTINE EXARIG (ICOLAC,ITLACC,M1,M2,IIICHA)
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
-INC SMRIGID
-INC TMCOLAC
-INC TMVECRIG
 
      iun=1
C     **************************** MRIGID ******************************
      ICO1=KCOLA(1)
      ICO2=KCOLA(2)
      ICO3=KCOLA(13)
      ICO4=KCOLA(16)
      ICO5=KCOLA(10)
      ICO7=KCOLA(3)
 
      ILISSE=ILISSG
      SEGACT ILISSE*MOD
 
      DO 606 IEL=M1,M2
         MRIGID=ITLAC(IEL)
         IF (MRIGID.EQ.0) GO TO 606
         SEGACT MRIGID*MOD
         NRIGEL=IRIGEL(/2)
 
         DO 607 I=1,NRIGEL
 
C       ... On rajoute le maillage sur la pile N° 1 ...
            IVA=IRIGEL(1,I)
            IF(IVA.GT.0) THEN
               CALL AJOUN(ICO1,IVA,ILISSE,iun)
               IF(IIICHA.EQ.1)IRIGEL(1,I)=-IVA
            ENDIF
 
C       ... On rajoute le maillage frottement sur la pile N° 1 ...
            IVA=IRIGEL(2,I)
            IF(IVA.GT.0) THEN
               CALL AJOUN(ICO1,IVA,ILISSE,iun)
               IF(IIICHA.EQ.1)IRIGEL(2,I)=-IVA
            ENDIF
 
C       ... On rajoute le IMATRI sur la pile N° 13 ...
             IVA=IRIGEL(4,I)
             if (iiicha.eq.1) then
*  en menage on n'active pas xmatri
                xmatri=IVA
                SEGACT xmatri*mod
                symre = irigel(7,I)
                segdes xmatri
             endif
             IF (IVA.GT.0) THEN
                CALL AJOUN(ICO3,IVA,ILISSE,iun)
                IF(IIICHA.EQ.1)IRIGEL(4,I)=-IVA
             ENDIF
 
 607     CONTINUE
 
*  NE PAS OUBLIER DE SAUVER LA TABLE SI ELLE EXISTE
         IVA=ISUPEQ
         IF (IVA.NE.0) THEN
C    ... On rajoute la TABLE sur la pile N° 10 ...
           CALL AJOUN(ICO5,IVA,ILISSE,iun)
           IF (IIICHA.EQ.1) ISUPEQ=IVA
         ENDIF
 
        IVA=ICHOLE
        IF (IVA.GT.0) THEN
C       ... On rajoute ICHOLE sur la pile N° 16 ...
          CALL AJOUN(ICO4,IVA,ILISSE,iun)
C       ... On met le pointeur negatif pour qu'on puisse reconnaitre le
C           pointeur sur la pile GEMAT (voir SORTRI, WRPIL et RESTRI) ...
          IF (IIICHA.EQ.1) ICHOLE=-IVA
        ENDIF
 
      IF (IMGEO1.GT.0) THEN
         IMGEOD=IMGEO1
         SEGACT IMGEOD*MOD
         DO 641 I=1,IMGEOR(/1)
            IVA=IMGEOR(I)
            IF(IVA.GT.0) THEN
               CALL AJOUN(ICO1,IVA,ILISSE,iun)
               IF(IIICHA.EQ.1) IMGEOR(I)=-IVA
            ENDIF
 641     CONTINUE
         SEGDES IMGEOD
      ENDIF
      IF (IVECRI.NE.0) THEN
        MVECRI=IVECRI
        SEGACT MVECRI*MOD
        DO 651 I=1,MELZON(/1)
          IVA = MELZON(I)
          IF (IVA.GT.0) THEN
             CALL AJOUN(ICO1,IVA,ILISSE,iun)
             IF(IIICHA.EQ.1) MELZON(I)=-IVA
          ENDIF
 651    CONTINUE
        SEGDES MVECRI
      ENDIF
        IVA=IMGEO2
        IF (IVA.NE.0) THEN
          CALL AJOUN(ICO2,IVA,ILISSE,iun)
          IF(IIICHA.EQ.1) IMGEO2=-IVA
        ENDIF
        iva=jrcond
        if (iva.ne.0) then
          call ajoun(ico7,iva,ilisse,iun)
          if(iiicha.eq.1) jrcond= -iva
        endif
        iva=jrsup
        if (iva.ne.0) then
          call ajoun(ico7,iva,ilisse,iun)
          if(iiicha.eq.1) jrsup= -iva
        endif
        iva=jrdepp
        if (iva.ne.0) then
          call ajoun(ico7,iva,ilisse,iun)
          if(iiicha.eq.1) jrdepp= -iva
        endif
        iva=jrdepd
        if (iva.ne.0) then
          call ajoun(ico7,iva,ilisse,iun)
          if(iiicha.eq.1) jrdepd= -iva
        endif
        iva=jrelim
        if (iva.ne.0) then
          call ajoun(ico7,iva,ilisse,iun)
          if(iiicha.eq.1) jrelim= -iva
        endif
        iva=jrgard
        if(iva.ne.0) then
          call ajoun(ico7,iva,ilisse,iun)
          if(iiicha.eq.1) jrgard= -iva
        endif
        iva=jrtot
        if (iva.ne.0) then
          call ajoun(ico7,iva,ilisse,iun)
          if(iiicha.eq.1) jrtot= -iva
        endif
        iva=imlag
        if (iva.ne.0) then
          call ajoun(ico1,iva,ilisse,iun)
          if(iiicha.eq.1) imlag= -iva
        endif
 
        SEGDES MRIGID
 
 606  CONTINUE
 
      RETURN
      END