Sources Esope | Cast3M

excham
C EXCHAM    SOURCE    PV090527  25/01/07    18:18:22     12116          
 
*--------------------------------------------------------------------*
*                                                                    *
*     Sous-programme appele par EXPIL, traitant la pile des          *
*     nouveaux CHAMELEMs.                                            *
*                                                                    *
*     Parametres:                                                    *
*                                                                    *
* e   ICOLAC  pointeur sur le chapeau des piles                      *
* es  ITLACC  pointeur de la pile examinee                           *
* e   M1      premier indice d'examen dans la pile                   *
* e   M2      dernier indice d'examen dans la pile                   *
* e   IIICHA  = 1 : on change les pointeurs                          *
*                                                                    *
*--------------------------------------------------------------------*
      SUBROUTINE EXCHAM(ICOLAC,ITLACC,M1,M2,IIICHA)
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
-INC SMCOORD
 
-INC SMCHAML
 
-INC TMCOLAC
 
      CHARACTER*8  MOTIP
      CHARACTER*16 MOTYP
 
      IF (M1.GT.M2) RETURN
 
      iun=1
      ICO1  = KCOLA( 1)
      ICO33 = KCOLA(33)
      ICO40 = KCOLA(40)
      ICO48 = KCOLA(48)
 
c*      ILISSE=ilissp
c*      SEGACT,ILISSE*MOD
 
      ILISSE=ILISSG
      SEGACT,ILISSE*MOD
 
      DO 10 IEL = M1, M2
 
         MCHELM = ITLAC(IEL)
         IF (MCHELM.EQ.0) GO TO 10
         SEGACT,MCHELM*MOD
 
         if (ichaml(/1).lt.0.or.ichaml(/1).gt.10000000) then
*  chelm  invalide. On le supprime de la pile
           moterr(1:8)='MCHELM  '
           interr(1)=itlac(iel)
           call erreur(861)
           itlac(iel)=0
           goto 10
         endif
*  traitement de la configuration du champ
         IF(MCLCNF.GT.0) THEN
            IVA = MCLCNF       
            IF (IVA.GT.0) THEN
              CALL AJOUN(ICO33,IVA,ILISSE,iun)
              IF (IIICHA.EQ.1) MCLCNF = -IVA
            ENDIF
          ENDIF
 
 
 
 
 
         DO 20 I = 1, ICHAML(/1)
            MCHAML = ICHAML(I)
            SEGACT,MCHAML*MOD
 
            IVA = IMACHE(I)
            IF (IVA.GT.0) THEN
              CALL AJOUN(ICO1,IVA,ILISSE,iun)
              IF (IIICHA.EQ.1) IMACHE(I) = -IVA
            ENDIF
 
            IVA = INFCHE(I,4)
            IF (IVA.GT.0) THEN
              CALL AJOUN(ICO40,IVA,ILISSE,iun)
              IF (IIICHA.EQ.1) INFCHE(I,4) = -IVA
            ENDIF
 
            DO 30 J=1,TYPCHE(/2)
               MOTYP = TYPCHE(J)
               IF (MOTYP(1:6).NE.'REAL*8') THEN
                  MOTIP(1:8)=MOTYP(9:16)
                  CALL TYPFIL(MOTIP,ITYP)
                  IF (ITYP.GT.0) THEN
                     NUMLIS=1
                     ilissd = ilissg
                     IF(ITYP.EQ.24) NUMLIS=6
C                     IF(ITYP.EQ.25) NUMLIS=4
                     IF(ITYP.EQ.26) NUMLIS=2
                     IF(ITYP.EQ.27) NUMLIS=5
                     IF(ITYP.EQ.32) then
                       NUMLIS=3
                       ILISSD=ilissp
                     ENDIF
                     IF (ITYP.EQ.36) NUMLIS=7
                     ICOTY = KCOLA(ITYP)
                     MELVAL = IELVAL(J)
                     SEGACT,MELVAL*MOD
                     NAL1 = IELCHE(/1)
                     NAL2 = IELCHE(/2)
c-dbg      if (nal1.eq.0.or.nal2.eq.0) then
c-dbg      write(6,*) 'EXCHAM : IELCHE de taille 0 !!!'
c-dbg      write(6,*) ' MCHELM =',mchelm,' MCHAML =',mchaml,' TYPCHE =',
c-dbg     &           motyp,' MELVAL =',MELVAL,VELCHE(/1),VELCHE(/2)
c-dbg      endif
                     DO I2 = 1, NAL2
                       DO I1 = 1, NAL1
                         IVA = IELCHE(I1,I2)
**                 if(iva.eq.2125243) write(6,*) 'excham iva ityp',
**   >                      iva,ityp  
 
 
                         IF (IVA.GT.0) THEN
                           CALL AJOUN(ICOTY,IVA,ILISSD,NUMLIS)
                           IF (IIICHA.EQ.1) IELCHE(I1,I2) = -IVA
                         ENDIF
                       END DO
                     END DO
 
                     SEGDES,MELVAL
                  ENDIF
               ELSE
*  segment de reel. Il a sa propre pile, IELVAL
                  IVA = IELVAL(J)  
**                  write(6,*) ' ajout de ',iva,' dans ',ico48
                  IF (IVA.GT.0) THEN
                    CALL AJOUN(ICO48,IVA,ILISSE,iun)
                    IF (IIICHA.EQ.1) IELVAL(J) = -IVA
                  ENDIF
               ENDIF
 30         CONTINUE
*           END DO
 
            SEGDES,MCHAML
 20      CONTINUE
*        END DO
 
         SEGDES,MCHELM
 10   CONTINUE
*     END DO
 
*      SEGDES,ILISSE
 
      RETURN
      END