Sources Esope | Cast3M

muchel
C MUCHEL    SOURCE    CB215821  26/08/24    21:17:25     12622          
      SUBROUTINE MUCHEL(IPCHE1,XFLOT,IPCHMU,IEPS)
C_______________________________________________________________________
C
C     MULTIPLIE UN CHPS PAR ELMTS PAR XFLO  SI IEPS=1
C     MULTIPLIE UN CHPS PAR ELMTS PAR 1/XFLO SI IEPS=-1
C     LE CHPS RESULTANT VOIT SON POINTEUR STOCKE DANS IRET
C     SI L OPERATION N EST PAS POSSIBLE IRET=0
C        PAR EXEMPLE SI IEPS=-1 ET XFLOT=0.
C        (APPELE PAR OPERMU)
C
C  ENTREES :
C  ---------
C
C     IPCHE1   POINTEUR SUR LE CHAMPS PAR ELEMENT
C     XFLOT    SCALAIRE
C     IEPS     = 1 SI MULTIPLICATION
C               -1 SI DIVISION
C
C  SORTIES :
C  ---------
C
C     IPCHMU   POINTEUR SUR LE CHAMPS*XFLOT**IEPS
C              =0  SI OPERATION IMPOSSSIBLE
C
C     CODE EBERSOLT JUIN 84
C
C     PASSAGE AUX NOUVEAUX CHAMELEM PAR JM CAMPENON LE 29 10 90
C
C_______________________________________________________________________
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
C
-INC SMCHAML
 
-INC PPARAM
-INC CCOPTIO
-INC SMCOORD
-INC SMLREEL
-INC SMEVOLL
C
      IPCHMU=0
C
      IF(IEPS.EQ.-1.AND.XFLOT.EQ.0.) GOTO 666
C
      IF(IEPS.EQ.1)  XFLOT1=XFLOT
      IF(IEPS.EQ.-1) XFLOT1=1.D0/XFLOT
C
      MCHEL1=IPCHE1
      SEGACT MCHEL1
      SEGINI,MCHELM=MCHEL1
      SEGDES MCHEL1
      IPCHMU=MCHELM
C
      DO 72 ISOUS=1,ICHAML(/1)
         MCHAM1=ICHAML(ISOUS)
         SEGACT MCHAM1
         SEGINI,MCHAML=MCHAM1
         SEGDES MCHAM1
         ICHAML(ISOUS)=MCHAML
         DO 73 ICOMP=1,IELVAL(/1)
            MELVA1=IELVAL(ICOMP)
            SEGACT MELVA1
            SEGINI,MELVAL=MELVA1
            SEGDES MELVA1
            IELVAL(ICOMP)=MELVAL
            N1PTEL=VELCHE(/1)
            IF (N1PTEL.NE.0) THEN
               N1EL  =VELCHE(/2)
               DO 667 IGAU=1,N1PTEL
                  DO 74 IB=1,N1EL
                     VELCHE(IGAU,IB)=XFLOT1*VELCHE(IGAU,IB)
  74           CONTINUE
  667          CONTINUE
            ELSE
               N2PTEL=IELCHE(/1)
               N2EL  =IELCHE(/2)
               IF (TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN
                  DO 668 IGAU=1,N2PTEL
                     DO 64 IB=1,N2EL
                        ILREE1=IELCHE(IGAU,IB)
                        CALL MUFLIR(ILREE1,XFLOT1,ILREEL,1)
                        IELCHE(IGAU,IB)=ILREEL
 64               CONTINUE
  668             CONTINUE
               ELSE IF (TYPCHE(ICOMP).EQ.'POINTEURPOINT   ') THEN
                  SEGACT,MCOORD*mod
                  NBNO=nbpts
                  NBNOI=NBNO
                  NBPTS=NBNO+(N2PTEL*N2EL)
                  SEGADJ,MCOORD
                  DO 669 IGAU=1,N2PTEL
                     DO 54 IB=1,N2EL
                        IP=IELCHE(IGAU,IB)
                        IREF=(IP-1)*(IDIM+1)
C
                        DO 55 IC=1,IDIM
                         XCOOR(NBNOI*(IDIM+1)+IC)=XCOOR(IREF+IC)*XFLOT1
 55                     CONTINUE
                    XCOOR(NBNOI*(IDIM+1)+(IDIM+1))=XCOOR(IREF+(IDIM+1))
                        IELCHE(IGAU,IB)=NBNOI+1
                        NBNOI=NBNOI+1
 54               CONTINUE
  669             CONTINUE
               ELSE IF (TYPCHE(ICOMP).EQ.'POINTEUREVOLUTIO') THEN
                  DO 670 IGAU=1,N2PTEL
                     DO 65 IB=1,N2EL
                        IEVOL1=IELCHE(IGAU,IB)
                        CALL MUFLEV(IEVOL1,XFLOT,IEVOL2,IEPS)
                        IELCHE(IGAU,IB)=IEVOL2
 65               CONTINUE
  670             CONTINUE
               ELSE
C
C                 NOM DE COMPOSANTE NON RECONNU
C
                  MOTERR(1:4)=NOMCHE(ICOMP)
                  CALL ERREUR(197)
                  SEGSUP MELVAL
                  SEGSUP MCHAML
                  SEGSUP MCHELM
                  IPCHMU=0
                  RETURN
               ENDIF
            ENDIF
            SEGDES MELVAL
C
  73     CONTINUE
         SEGDES MCHAML
C
  72  CONTINUE
      SEGDES MCHELM
C
  666 CONTINUE
      RETURN
      END