Sources Esope | Cast3M

exarig
C EXARIG    SOURCE    PV        21/01/21    21:15:20     10862          
      SUBROUTINE EXARIG (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 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=======================================================================
C  TABLEAU KCOLA :
C    1  MELEME  2 CHPOIN  3 MRIGID  4 MCHAFF  5 MCHELM  6
C    7          8 MSOLUT  9 MSTRUC 10 MTABLE 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)
-INC SMRIGID
 
-INC PPARAM
-INC CCOPTIO
-INC TMCOLAC
-INC TMVECRIG
      iun=1
C     **************************** MRIGID ******************************
      ICO1=KCOLA(1)
*     ICO2=KCOLA(11)    ON REMPLACE PAR UN OBJET MELEME  AM  12/2/90
      ICO3=KCOLA(13)
      ICO4=KCOLA(16)
      ICO5=KCOLA(10)
      ICO6=KCOLA(2)
      ico7=kcola(3)
      ILISSE=ILISSG
      SEGACT ILISSE*MOD
 503  CONTINUE
 
      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.EQ.0) GOTO 612
            IF(IVA.GT.0) THEN
               CALL AJOUN(ICO1,IVA,ILISSE,iun)
               IF(IIICHA.EQ.1)IRIGEL(2,I)=-IVA
            ENDIF
  612       CONTINUE
 
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=IRIGEL(4,I)
                SEGACT xmatri*mod
                symre = irigel(7,I)
                segdes xmatri
             endif
             if (ionive.ge.20) then
             IF(IVA.GT.0) THEN
                CALL AJOUN(ICO3,IVA,ILISSE,iun)
                IF(IIICHA.EQ.1)IRIGEL(4,I)=-IVA
             ENDIF
             endif
 
 607     CONTINUE
 
*  NE PAS OUBLIER DE SAUVER LA TABLE SI ELLE EXISTE
      IF (ISUPEQ.NE.0) THEN
C    ... On rajoute la TABLE sur la pile N° 10 ...
         IVA=ISUPEQ
         CALL AJOUN(ICO5,IVA,ILISSE,iun)
         IF(IIICHA.EQ.1) ISUPEQ=IVA
      ENDIF
 
      IF(ICHOLE.EQ.0) GOTO 613
         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 négatif pour qu'on puisse reconnaître
C           le pointeur sur la pile du pointeur GEMAT (voir SORTRI, WRPIL
C           et RESTRI) ...
            IF(IIICHA.EQ.1) ICHOLE=-IVA
         ENDIF
 613  CONTINUE
 
      IF(IMGEO1.EQ.0) GOTO 640
         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
 640  CONTINUE
      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
      IF (IMGEO2.NE.0) THEN
         IVA=IMGEO2
         CALL AJOUN(ICO6,IVA,ILISSE,iun)
         IF(IIICHA.EQ.1) IMGEO2=-IVA
      ENDIF
      if(jrcond.ne.0) then
        iva=jrcond
       call ajoun(ico7,iva,ilisse,iun)
        if(iiicha.eq.1) jrcond= -iva
      endif
      if(jrsup.ne.0) then
        iva=jrsup
       call ajoun(ico7,iva,ilisse,iun)
        if(iiicha.eq.1) jrsup= -iva
      endif
      if(jrdepp.ne.0) then
        iva=jrdepp
       call ajoun(ico7,iva,ilisse,iun)
        if(iiicha.eq.1) jrdepp= -iva
      endif
      if(jrdepd.ne.0) then
        iva=jrdepd
       call ajoun(ico7,iva,ilisse,iun)
        if(iiicha.eq.1) jrdepd= -iva
      endif
      if(jrelim.ne.0) then
        iva=jrelim
       call ajoun(ico7,iva,ilisse,iun)
        if(iiicha.eq.1) jrelim= -iva
      endif
      if(jrgard.ne.0) then
        iva=jrgard
       call ajoun(ico7,iva,ilisse,iun)
        if(iiicha.eq.1) jrgard= -iva
      endif
      if(jrtot.ne.0) then
        iva=jrtot
       call ajoun(ico7,iva,ilisse,iun)
        if(iiicha.eq.1) jrtot= -iva
      endif
      if(imlag.ne.0) then
*      write (6,*) ' dans exarig ',imlag
        iva=imlag
        call ajoun(ico1,iva,ilisse,iun)
        if(iiicha.eq.1) imlag= -iva
        endif
      SEGDES MRIGID
 606  CONTINUE
      GO TO 599
C*********************************************************************
 599  CONTINUE
*      SEGDES ILISSE
      RETURN
      END