Sources Esope | Cast3M

champo
C CHAMPO    SOURCE    OF166741  24/10/03    21:15:05     12022          
      SUBROUTINE CHAMPO(IPCHAM,IMOY1,IPCHPO,IRET)
C=======================================================================
C
C     TRANSFORME UN MCHAML EN CHPOINT
C
C
C     ATTENTION LES COMPOSANTES DE IPCHAM NE DOIVENT PAS ETRE '    '
C                               ( DES MOT BLANCS )
C
C  ENTREES
C
C     IPCHAM=Pointeur sur un MCHAML
C     IMOY  =1 si moyenne sur les elements, 0 si somme
C
C  SORTIES
C
C     IPCHPO=Pointeur sur un CHPOINT
C     IRET=1 OU 0 suivant succes ou non
C                 Message d'erreur imprime si IRET=0
C
C
C=======================================================================
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
 
-INC SMCHAML
-INC SMCHPOI
-INC SMELEME
-INC SMCOORD
-INC TMTRAV
 
      SEGMENT ICPR(nbpts)
      SEGMENT MTRA1
        CHARACTER*(LOCOMP) ICOMP(0)
      ENDSEGMENT
      SEGMENT MTRA2
        INTEGER     MHAR(0)
      ENDSEGMENT
 
C     Pour de l'optimisation
      CHARACTER*(LOCOMP) MO4a,MO4b
 
*      write(ioimp,*) 'coucou champo'
*      call ecrobj('MCHAML  ',IPCHAM)
*      call prlist
*      CALL ACTOBJ('MCHAML  ',IPCHAM,1)
 
      IRET=1
 
C                          POUR LE CHAPEAU DU CHPOINT
C     Certaines SUBROUTINES envoie IMOY1 en CONSTANT EXPRESSION donc le modifier ne fait pas bon menage
C     Je le recopie IMOY &lt;-- IMOY1
      IMOY=IMOY1
 
      JFLAG=0
      IF (IMOY.GE.10) THEN
        JFLAG=1
        IMOY=IMOY-10
      ENDIF
 
*     ACTIVATION DU MCHAML
 
      MCHELM=IPCHAM
      L1=TITCHE(/1)
      N1=INFCHE(/1)
      N3=INFCHE(/2)
      IF (N3.NE.6) then
        write(ioimp,*) 'CHAMPO : INFCHE(/2) != 6'
        call erreur(5)
      endif
      IFACHE=IFOCHE
      NSOUS =ICHAML(/1)
C-----------------------------------------------------------------------
C
C     BOUCLE SUR LES SOUS REFERENCES DU CHAMELEM
C              MISE EN PLACE DES NOMS DE COMPOSANTES DANS ICOMP
C
C-----------------------------------------------------------------------
      CALL oooprl(1)
      SEGINI MTRA1,MTRA2,ICPR
      CALL oooprl(0)
      NNNOE=0
 
*     BOUCLE SUR LES SOUS ZONES
 
      DO 100 ISOUS=1,NSOUS
 
*       ACTIVATION DU MELEME
 
        IVACHE = INFCHE(ISOUS,3)
        MELEME = IMACHE(ISOUS)
        MCHAML = ICHAML(ISOUS)
        if (mchaml.le.0) goto 100
 
*       RECOPIE DES NOMS DE COMPOSANTES
 
        DO 110 IB=1,NOMCHE(/2)
          MO4a = NOMCHE(IB)
          DO 120 IC=1,ICOMP(/2)
            MO4b=ICOMP(IC)
            IF(MO4a.EQ.MO4b .AND. MHAR(IC).EQ.IVACHE) GOTO 110
  120     CONTINUE
          ICOMP(**)=MO4a
          MHAR(**) =IVACHE
  110   CONTINUE
 
*   RECUPERATION DES NUMEROS DE NOEUDS
        DO 111 JOP= 1,NUM(/2)
          DO 113 IOP = 1,NUM(/1)
            IPT= NUM(IOP,JOP)
            IF (ICPR(IPT).EQ.0) THEN
              NNNOE=NNNOE+1
              ICPR(IPT)=NNNOE
            ENDIF
  113     CONTINUE
  111   CONTINUE
 
  100 CONTINUE
 
      NNIN=ICOMP(/2)
      SEGINI MTRAV
      DO 112 IOP=1,NNIN
        INCO(IOP)=ICOMP(IOP)
        NHAR(IOP)=MHAR(IOP)
  112 CONTINUE
 
C-----------------------------------------------------------------------
C
C     BOUCLE SUR LES SOUS REFERENCES DU CHAMP PAR ELEMENT
C
C-----------------------------------------------------------------------
      DO 300 ISOUS=1,NSOUS
 
         IVACHE=INFCHE(ISOUS,3)
         MELEME=IMACHE(ISOUS)
         MCHAML=ICHAML(ISOUS)
         if (mchaml.le.0) goto 300
         NCP=NOMCHE(/2)
 
         NBNN  =NUM(/1)
         NBELEM=NUM(/2)
C
C       BOUCLE SUR LES COMPOSANTES LES ELEMENTS ET LES NOEUDS
C
         DO 320 IB=1,NBELEM
            DO 3201 IC=1,NBNN
C
C         REPERAGE D UN POINT
               IPT=ICPR(NUM(IC,IB))
               DO 330 ID=1,NCP
                  MELVAL=IELVAL(ID)
                  NBPTEL=VELCHE(/1)
                  NEL   =VELCHE(/2)
                  IBMN=MIN(IB,NEL)
                  IGMN=MIN(IC,NBPTEL)
                  MO4a=NOMCHE(ID)
                  DO 3301 IE=1,NNIN
                     MO4b=ICOMP(IE)
                     IF(MO4a.NE.MO4b .OR. IVACHE.NE.MHAR(IE)) GOTO 3301
 
                     IF (JFLAG.EQ.1) THEN
C
C               ADDITION DANS BB POUR LES MCHAML AUX NOEUDS
C
                        BVALT=0.D0
                        DO 331 ICEL=1,NBPTEL
                           BVALT=BVALT+VELCHE(ICEL,IBMN)
 331                    CONTINUE
                        BVALT=BVALT/NBPTEL
                        BB(IE,IPT)=BB(IE,IPT)+BVALT
                     ELSE
                        BB(IE,IPT)=BB(IE,IPT)+VELCHE(IGMN,IBMN)
                     ENDIF
                     IBIN(IE,IPT)=IBIN(IE,IPT)+1
 3301             CONTINUE
 330           CONTINUE
               IGEO(IPT)=NUM(IC,IB)
 3201       CONTINUE
 320     CONTINUE
 300  CONTINUE
 
      IF (IMOY.EQ.1) THEN
         DO 340 IPT=1,NNNOE
            DO 3401 IE=1,NNIN
               IF (IBIN(IE,IPT).NE.0) THEN
                  BB(IE,IPT)=BB(IE,IPT)/IBIN(IE,IPT)
               ELSE
                  BB(IE,IPT)=0.D0
               ENDIF
 3401       CONTINUE
 340     CONTINUE
      ENDIF
 
      CALL CRECHP(MTRAV,IPCHPO)
      SEGSUP MTRAV,ICPR,MTRA1,MTRA2
      MCHPOI=IPCHPO
      IFOPOI=IFACHE
      MTYPOI=TITCHE
      IF ( IMOY .EQ. 0) THEN
*       on somme les participations des elements: discret
         JATTRI(1) =  2
      ELSE
*      on prend la moyenne entre les éléments: diffus
         JATTRI(1) = 1
      ENDIF
 
C      RETURN
      END