Sources Esope | Cast3M

chelco
C CHELCO    SOURCE    PASCAL    21/06/22    21:15:00     11039          
      SUBROUTINE CHELCO(IVAL,IPCHEL,IPCHE1,IPCHE2,IPCHE3)
 
C=======================================================================
C ENTREES
C   IVAL = 0 SI ON VEUT IDIM CHAMELEM 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 SUR UN CHAMP PAR ELEMENT (TYPE MCHAML)
 
C SORTIES
C   IPCHE1  =POINTEURS SUR LES CHAMP/ELEMENT CONTENANT LES COORDONNEES
C   IPCHE2
C   IPCHE3
C
C     EBERSOLT OCT  85
C     NOUVEAUX CHAMELEMS P DOWLATYARI OCT 91
C=======================================================================
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
-INC SMCHAML
-INC SMELEME
-INC SMINTE
-INC SMCOORD
 
-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
      CHARACTER*4 NOMEL
C
      SEGMENT MTRA
         REAL*8 XE(3,NBNN)
      ENDSEGMENT
C
      DATA XZER/0.D0/
C
      IPCHE1 = 0
      IPCHE2 = 0
      IPCHE3 = 0
C
      MCHEL1=IPCHEL
      N1=MCHEL1.INFCHE(/1)
      N3=MCHEL1.INFCHE(/2)
      L1=8
      NSOUS=N1
C
      IF(IVAL.EQ.0)THEN
        IDEB=IDIM
        IFIN=1
      ELSE
         IDEB=IVAL
         IFIN=IVAL
      ENDIF
C
      NCHE=0
C
C      BOUCLE SUR LES COMPOSANTES
C
      DO 1000  ICO=IDEB,IFIN,-1
C
C   ON INITIALISE LE MCHAML CONTENANT LA COORDONNEE ICO
C
      SEGINI,MCHELM
      NCHE=NCHE+1
      IF(NCHE.EQ.1)IPCHE1=MCHELM
      IF(NCHE.EQ.2)IPCHE2=MCHELM
      IF(NCHE.EQ.3)IPCHE3=MCHELM
      IFOCHE=MCHEL1.IFOCHE
      TITCHE='SCALAIRE'
C
C    BOUCLE SUR LES SOUS-ZONES
C
      DO 100 ISOUS=1,NSOUS
C
      CONCHE(ISOUS)=MCHEL1.CONCHE(ISOUS)
      IMACHE(ISOUS)=MCHEL1.IMACHE(ISOUS)
C
      DO  10 IO=1,N3
         INFCHE(ISOUS,IO)=MCHEL1.INFCHE(ISOUS,IO)
  10  CONTINUE
      N2=1
      SEGINI MCHAML
      ICHAML(ISOUS)=MCHAML
      NOMCHE(1)='SCAL'
      TYPCHE(1)='REAL*8'
C
      MELEME=IMACHE(ISOUS)
      NBELEM=NUM(/2)
      NBNN=NUM(/1)
      NOMEL=NOMS(ITYPEL)
C
      ISUP=INFCHE(ISOUS,6)
      IF(ISUP.NE.1)THEN
        MINTE=INFCHE(ISOUS,4)
        NBPGAU=SHPTOT(/3)
      ELSE
        NBPGAU=NBNN
      ENDIF
C
      N1EL  =NBELEM
      N1PTEL=NBPGAU
      N2EL  =0
      N2PTEL=0
      SEGINI MELVAL
      IELVAL(1)=MELVAL
      SEGINI MTRA
C
      NBOUC=NBNN
      IF(NOMEL.EQ.'RAP3'.AND.ISUP.NE.1) NBOUC=6
      IF(NOMEL.EQ.'LIP6'.AND.ISUP.NE.1) NBOUC=12
      IF(NOMEL.EQ.'LIP8'.AND.ISUP.NE.1) NBOUC=16
 
      DO   200 IB=1,NBELEM
C
      CALL ZERO(XE,3,NBNN)
      CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
C
      DO   210  IGAU=1,NBPGAU
C
      IF(ISUP.NE.1)THEN
       XX=XZER
       DO 220  ID=1,NBOUC
         XX=XX+SHPTOT(1,ID,IGAU)*XE(ICO,ID)
 220   CONTINUE
       ELSE
         XX=XE(ICO,IGAU)
       ENDIF
C+PPj
C      ON DIVISE PAR 2 LE RESULTAT POUR CERTAINS ELEMENTS DE JOINTS
C  AM 29/3/16  UNIQUEMENT SI LE SUPPORT EST DIFFERENT DE 1
       IF(ISUP.NE.1) THEN
       IF((NOMEL.EQ.'RAC2').OR.(NOMEL.EQ.'LIA3')
     .  .OR.(NOMEL.EQ.'LIA4').OR.(NOMEL.EQ.'LIA6').OR.(NOMEL.EQ.'LIA8')
     .  .OR.(NOMEL.EQ.'RAP3').OR.(NOMEL.EQ.'LIP6').OR.(NOMEL.EQ.'LIP8'))
     .   XX=XX/2
       ENDIF
C+PPj
C
      VELCHE(IGAU,IB)=XX
C
 210  CONTINUE
 200  CONTINUE
      SEGSUP MTRA
C
 100  CONTINUE
 
C
 1000 CONTINUE
 
      END