C CHELCO    SOURCE    OF166741  25/12/09    21:15:02     12415          

C=======================================================================
C ENTREES
C   IVAL = 0 SI ON VEUT IDIM CHAMELEMS CONTENANT CHACUN UNE COMPOSA
C   IVAL = 1 SI ON VEUT LA PREMIERE COMPOSANTE
C   IVAL = 2 SI ON VEUT LA DEUXIEME COMPOSANTE
C   IVAL = 3 SI ON VEUT LA TROISIEME COMPOSANTE
C   IPCHEL = POINTEUR ACTIF SUR UN CHAMP PAR ELEMENT (TYPE MCHAML)

C SORTIES
C   IPCHE1 = POINTEURS ACTIFS SUR CHAMP/ELEMENT DE CHAQUE COORDONNEE
C   IPCHE2
C   IPCHE3
C=======================================================================

      SUBROUTINE CHELCO(IVAL,IPCHEL,IPCHE1,IPCHE2,IPCHE3)

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

-INC PPARAM
-INC CCOPTIO

-INC SMCOORD
-INC SMCHAML
-INC SMELEME
-INC SMINTE

      SEGMENT MTRA
        REAL*8 XE(3,NBMA)
      ENDSEGMENT

      IF (IVAL.EQ.0) THEN
        IDEB=1
        IFIN=IDIM
      ELSE
        IDEB=IVAL
        IFIN=IVAL
      ENDIF

      MCHEL1 = IPCHEL
      N1 = MCHEL1.INFCHE(/1)
      N3 = MCHEL1.INFCHE(/2)
      L1 = 8

      NSOUS = N1

C (Sur)Dimensionnement & Initialisation du segment MTRA
      NBMA = 0
      DO ISOUS = 1, NSOUS
        MELEME = mchel1.IMACHE(ISOUS)
        NBMA   = MAX( NBMA, meleme.NUM(/1))
      ENDDO
      SEGINI,MTRA

C BOUCLE SUR LES COMPOSANTES A EXTRAIRE

      ich = 0
      IPCHE1 = 0
      IPCHE2 = 0
      IPCHE3 = 0

      DO ICO = IFIN, IDEB, -1
C
C   ON INITIALISE LE MCHAML CONTENANT LA COORDONNEE ICO
C
        SEGINI,MCHELM
        mchelm.IFOCHE = MCHEL1.IFOCHE
        mchelm.TITCHE = 'SCALAIRE'

        ich = ich + 1
        IF (ich.EQ.1) IPCHE1 = MCHELM
        IF (ich.EQ.2) IPCHE2 = MCHELM
        IF (ich.EQ.3) IPCHE3 = MCHELM
C
C   BOUCLE SUR LES SOUS-ZONES
C
        DO ISOUS = 1, NSOUS

          mchelm.CONCHE(ISOUS) = MCHEL1.CONCHE(ISOUS)
          mchelm.IMACHE(ISOUS) = MCHEL1.IMACHE(ISOUS)
          DO isc = 1, N3
            mchelm.INFCHE(ISOUS,isc) = MCHEL1.INFCHE(ISOUS,isc)
          ENDDO

          MELEME = mchelm.IMACHE(ISOUS)
          NBELEM = meleme.NUM(/2)
          NBNN   = meleme.NUM(/1)

          ISUP = mchelm.INFCHE(ISOUS,6)
          IF (ISUP.NE.1) THEN
            MINTE  = mchelm.INFCHE(ISOUS,4)
            NBPGAU = minte.SHPTOT(/3)
          ELSE
            NBPGAU = NBNN
          ENDIF

          N2 = 1
          SEGINI MCHAML
          mchaml.NOMCHE(1) = 'SCAL    '
          mchaml.TYPCHE(1) = 'REAL*8  '

          mchelm.ICHAML(ISOUS) = MCHAML

          N1EL   = NBELEM
          N1PTEL = NBPGAU
          N2EL   = 0
          N2PTEL = 0
          SEGINI,MELVAL
          mchaml.IELVAL(1) = MELVAL

          IF (ISUP.NE.1) THEN
            facz = 1.D0
            NBOUC = NBNN
C      ON DIVISE PAR 2 LE RESULTAT POUR CERTAINS ELEMENTS DE JOINTS
C      UNIQUEMENT SI LE SUPPORT EST DIFFERENT DE 1
            ity = meleme.ITYPEL
            IF ( ity.EQ.12 .OR. ity.EQ.18 .OR. ity.EQ.19 .OR.
     &           ity.EQ.20 .OR. ity.EQ.21 .OR. ity.EQ.29 .OR.
     &           ity.EQ.30 .OR. ity.EQ.31 ) THEN
              facz = 0.5D0
              IF (ity.EQ.29) NBOUC =  6
              IF (ity.EQ.30) NBOUC = 12
              IF (ity.EQ.31) NBOUC = 16
            ENDIF

            DO IB = 1, NBELEM
              CALL ZERO(XE,3,NBNN)
              CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
              DO IGAU = 1, NBPGAU
                XX = 0.D0
                DO isc = 1, NBOUC
                  XX = XX + SHPTOT(1,isc,IGAU)*XE(ICO,isc)
                ENDDO
                VELCHE(IGAU,IB) = facz*XX
              ENDDO
            ENDDO

          ELSE
            DO IB = 1, NBELEM
              CALL ZERO(XE,3,NBNN)
              CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
              DO IGAU = 1, NBPGAU
                VELCHE(IGAU,IB) = XE(ICO,IGAU)
              ENDDO
            ENDDO
          ENDIF

        ENDDO
C   Fin BOUCLE sur les SOUS-ZONES

      ENDDO
C Fin BOUCLE sur les COMPOSANTEs

      SEGSUP MTRA

c      RETURN
      END