C ELCHPO    SOURCE    CB215821  20/11/25    13:27:10     10792          

C=======================================================================
c  fonction:
c  sous routine pour arranger un chpo qui a souffert apres elim
c
c  arguments:
c  ip1 (e/s) pointeur sur le champ par point / ACTIF en SORTIE
c   
c
c  variables:
c * mtrav : - bb(i,j) est la valeur de la ieme inconnue de champ pour
c          le jieme noeud du tableau igeo .
c           - inco(nnin) contient le nom des nnin inconnues differentes
c           - ibin(i,j)=1 ou 0 indique que la ieme inconnue du champ
c          existe pour le jieme noeud du tableau igeo .
c           - igeo(i) est le numero a mettre dans un objet meleme pour
c          referencer le ieme noeud .
c
C=  A. DE GAYFFIER, le 7 juillet 1994.                                 =
C=======================================================================

      SUBROUTINE ELCHPO(IP1,iratt)

      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)


-INC PPARAM
-INC CCOPTIO
-INC SMCHPOI
-INC SMELEME
-INC SMCOORD
-INC TMTRAV

      SEGMENT MTR1
        CHARACTER*(LOCOMP) TINCO(NNIN)
      ENDSEGMENT
      SEGMENT MTR2
        INTEGER TIBIN(NNINR,NNNOER)
        REAL*8 TBB(NNINR,NNNOER)
      ENDSEGMENT
      SEGMENT MTR3
        INTEGER TGEO(TGEOD)
      ENDSEGMENT
      SEGMENT MTR3I
        INTEGER ITGEO(ITGEOD)
      ENDSEGMENT
      SEGMENT MTR4
        INTEGER THARM(0)
      ENDSEGMENT
      SEGMENT MTR5
        INTEGER ICO(NC)
      ENDSEGMENT
      INTEGER TGEOD

      PARAMETER (Epsi=1.D-30)
      CHARACTER*(LOCOMP) cmot
      LOGICAL FLAG

      MCHPOI=IP1
      SEGACT,MCHPOI

C    verification de la compatibilite des natures
      NAT=JATTRI(/1)
      NATU=NAT
      IF (NATU.GT.0) THEN
        NATU=JATTRI(1)
      ENDIF
C    la nature est indeterminee on ne peut rien faire
      IF (NATU.EQ.0) THEN
        Iratt=2
        RETURN
      ENDIF

c    on eclate le champ par point dans le segment mtrav
      NNINR=10
      NNNOER=10000
      NNIN=0
      NNNOE=0
      TGEOD =1000
      ITGEOD=1000
      SEGINI,MTR1,MTR2,MTR3,MTR3I,MTR4

c boucle sur les msoupo
c
      DO 60 i=1,IPCHP(/1)
        MSOUPO=IPCHP(i)
        SEGACT,MSOUPO
        MPOVAL=IPOVAL
        IF (MPOVAL.EQ.0) THEN
          SEGSUP,MTR1,MTR2,MTR3,MTR3I,MTR4
          RETURN
        ENDIF
c
c     boucle sur les composantes
c     on remplit tinco avec le nom des composantes
        NC=NOCOMP(/2)
        SEGINI,MTR5
        DO 20 j=1,NC
          cmot=NOCOMP(j)
          DO k=1,NNIN
            IF (TINCO(k).EQ.cmot) THEN
              ICO(j)=k
              GOTO 20
            ENDIF
          ENDDO
c         il y une inconnue de plus dans tinco
          NNIN=NNIN+1
          ICO(j)=NNIN
          SEGADJ,MTR1
          TINCO(NNIN)=cmot
          THARM(**)=NOHARM(j)
 20     CONTINUE
c
c      boucle sur les noeuds du msoupo
        MELEME=IGEOC
        SEGACT,MELEME
        NOE=NUM(/2)
        DO 40 j=1,NOE
c         pour savoir si le noeud j appartient a geo
          jnoe=NUM(1,j)
          if (jnoe.gt.ITGEOD) then
           ITGEOD=jnoe*2
           segadj mtr3i
          endif
          IF (itgeo(jnoe).ne.0) goto 40
c     le noeud n'etait pas dans la pile
          NNNOE=NNNOE+1
          if (nnnoe.gt.tgeod) then
           tgeod=nnnoe*2
           segadj mtr3
          endif
          TGEO(nnnoe)=jnoe
          itgeo(jnoe)=nnnoe
 40     CONTINUE
c
c encore une boucle sur les noeuds pour remplir tbb avec les valeurs
c  ico et ino servent pour retrouver les numeros dans tgeo et tinco
        if (nnin.gt.nninr) then
          nninr=nnin+10
        endif
        if (nnnoe.gt.nnnoer) then
          nnnoer=nnnoe+10000
        endif
        if (nninr.ne.tibin(/1).or.nnnoer.ne.tibin(/2)) SEGADJ,MTR2
        SEGACT,MPOVAL
        DO k=1,NC
          FLAG=.TRUE.
          icok=ICO(k)
          DO j=1,NUM(/2)
c             il s'agit d'un point double
            inoj=itgeo(num(1,j))
            IF (TIBIN(icok,inoj).NE.0) THEN
              IF (NATU.EQ.2) THEN
c              le champ est discret on additionne
                TBB(icok,inoj)=TBB(icok,inoj)+VPOCHA(j,k)
              ELSE
c              le champ est diffus il faut l'egalite
                V1=TBB(icok,inoj)
                V2=VPOCHA(j,k)
                VMOY=0.5*(V1+V2)+Epsi
c                test sur la difference relative
c                on commence par chercher un ordre de grandeur de la
c                composante sur la sous zone pour faire un test sur la
c                valeur absolue de la difference
                IF (ABS(V2-V1).GT.(1.D-4*ABS(VMOY))) THEN
                  IF (FLAG) THEN
                    THEMAX=0.
                    DO l=1,NUM(/2)
                      THEMAX=MAX(ABS(VPOCHA(l,k)),THEMAX)
                    ENDDO
                    FLAG=.FALSE.
                  ENDIF
c             il n'y a pas egalite : erreur
                  IF (ABS(V2-V1).GT.(1.D-4*THEMAX)) THEN
                    Iratt=2
c  les lignes suivantes sont en commentaire de facon
c  a traiter quand meme les champ par point diffus dont les
c  valeurs sont distinctes: on prend la moyenne
c                   SEGSUP,mtr1,mtr2,mtr3,mtr4,mtr5,mtr6
c                   RETURN
                  ENDIF
                ENDIF
c      on affecte la valeur moyenne dans tous les cas
                TBB(icok,inoj)=VMOY
              ENDIF
            ELSE
              TBB(icok,inoj)=VPOCHA(j,k)
              TIBIN(icok,inoj)=1
            ENDIF
          ENDDO
        ENDDO
        SEGSUP,MTR5
 60   CONTINUE

C= Remplissage du segment MTRAV (ITRAV)
      SEGINI,MTRAV
      DO i=1,NNIN
        INCO(i)=TINCO(i)
C*OF    NHAR(i)=THARM(i)
      ENDDO
C*OF IF temporaire en attendant operateur remplacant procedure creer_3D
      IF (IFOMOD.EQ.1) THEN
        DO i=1,NNIN
          NHAR(i)=THARM(i)
        ENDDO
      ENDIF
      DO j=1,NNNOE
        IGEO(j)=TGEO(j)
        DO i=1,NNIN
          BB(i,j)=TBB(i,j)
          IBIN(i,j)=TIBIN(i,j)
        ENDDO
      ENDDO
      ITRAV=MTRAV

c     reconstuction de la partition
      CALL CRECHP(ITRAV,ICHP)
c     on ajuste le contenu du chapeau
      MCHPO1=ICHP
      SEGACT,MCHPO1
      NSOUPO=MCHPO1.IPCHP(/1)
      SEGADJ,MCHPOI
      DO i=1,NSOUPO
        IPCHP(i)=MCHPO1.IPCHP(i)
      ENDDO

      SEGSUP,MCHPO1
      SEGSUP,MTR1,MTR2,MTR3,MTR3I,MTR4,MTRAV

      RETURN
      END