Sources Esope | Cast3M

chelco
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