Sources Esope | Cast3M

varche
C VARCHE    SOURCE    CB215821  20/11/04    21:21:53     10766          
 
*_______________________________________________________________________
*         MULTIPLICATION D'UN MCHAML PAR UN OBJET EVOLUTION
*                (APPELE PAR OPERMU)
*
*  ENTREES :
*  _________
*     IPCHE1   POINTEUR SUR UN CHAMELEM (TYPE MCHAML)
*     IPEVOL   POINTEUR SUR UN OBJET EVOLUTION
*
*  SORTIE :
*  ________
*     IPCHMU   POINTEUR SUR UN CHAMELEM RESULTAT (TYPE MCHAML)
*     IRET     =0 SI L'OPERATION EST IMPOSSIBLE.
*_______________________________________________________________________
 
      SUBROUTINE VARCHE (IPCHE1,IPEVOL,IPCHMU,IRET)
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
 
-INC PPARAM
-INC CCOPTIO
 
-INC SMCHAML
-INC SMLREEL
-INC SMEVOLL
-INC SMCOORD
 
      IRET = 0
      IPCHMU = 0
*
*  ON RECUPERE L'OBJET EVOLUTION
*
      MEVOLL = IPEVOL
      SEGACT,MEVOLL
      KEVOLL = mevoll.IEVOLL(1)
      SEGDES,MEVOLL
      SEGACT,KEVOLL
      IF (kevoll.TYPX .NE. 'LISTREEL' .OR.
     &    kevoll.TYPY .NE. 'LISTREEL') THEN
        SEGDES,KEVOLL
        MOTERR(1:8) = 'LISTREEL'
        CALL ERREUR(37)
        RETURN
      ENDIF
      MLREE1 = kevoll.IPROGX
      MLREE2 = kevoll.IPROGY
      SEGDES,KEVOLL
 
      SEGACT,MLREE1,MLREE2
      NBPOIX = MLREE1.PROG(/1)
      NBPOIY = MLREE2.PROG(/1)
* Petites verifications sur le contenu de l'evolution
      IF (NBPOIX.NE.NBPOIY) THEN
        CALL ERREUR(577)
        GOTO 999
      ENDIF
      JORDO = 0
      CALL VARIFV(MLREE1.PROG,NBPOIX,JORDO)
      IF (JORDO.EQ.0) THEN
        CALL ERREUR(872)
        GOTO 999
      ENDIF
*
*     ACTIVATION DU CHAMELEM
*
      MCHELM = IPCHE1
      SEGINI,MCHEL1 = MCHELM
 
      NSOUS = MCHEL1.ICHAML(/1)
*
*     BOUCLE SUR LES SOUS ZONES
*
      DO 100 ISOUS = 1, NSOUS
 
         MCHAML = MCHEL1.ICHAML(ISOUS)
         SEGINI,MCHAM1=MCHAML
         MCHEL1.ICHAML(ISOUS) = MCHAM1
         NCOMP = MCHAM1.IELVAL(/1)
 
         DO 200 ICOMP = 1, NCOMP
 
            MELVAL = MCHAM1.IELVAL(ICOMP)
            SEGACT,MELVAL
            N1PTEL = MELVAL.VELCHE(/1)
            N1EL   = MELVAL.VELCHE(/2)
            N2PTEL = MELVAL.IELCHE(/1)
            N2EL   = MELVAL.IELCHE(/2)
            SEGINI,MELVA1
            MCHAM1.IELVAL(ICOMP) = MELVA1
 
            IF (N1PTEL.EQ.0) THEN
               IF (MCHAM1.TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN
                  DO 201 IB = 1, N2EL
                     DO 201 IGAU = 1, N2PTEL
                        MLREE3 = MELVAL.IELCHE(IGAU,IB)
                        SEGACT,MLREE3
                        JG = MLREE3.PROG(/1)
                        SEGINI,MLREEL
                        DO 202 IPROG = 1, JG
                           XTT1 = MLREE3.PROG(IPROG)
                           CALL VARIFO(MLREE1.PROG,MLREE2.PROG,NBPOIX,
     &                                 JORDO,XTT1, YTT1)
                           MLREEL.PROG(IPROG) = YTT1
 202                    CONTINUE
                        SEGDES,MLREE3,MLREEL
                        MELVA1.IELCHE(IGAU,IB) = MLREEL
 201              CONTINUE
               ELSE IF (MCHAM1.TYPCHE(ICOMP).EQ.'POINTEURPOINT   ') THEN
c*// Attention : risque de probleme si travail avec ASSIstant(s) en // 
c*// a cause du segment "global" MCOORD qui est ici modifie !
c*   On peut se demander si le present cas a deja ete rencontre...
                  IDIMP1 = IDIM + 1
                  SEGACT,MCOORD*MOD
                  NBNOI = nbpts 
                  NBPTS = NBNOI + (N2EL*N2PTEL)
                  SEGADJ,MCOORD
                  NBPTS = NBNOI
                  DO 203 IB = 1, N2EL
                     DO 203 IGAU =1, N2PTEL
                        IP    = MELVAL.IELCHE(IGAU,IB)
                        IREF  = (IP-1)*IDIMP1
                        NBPTS = NBPTS + 1
                        INEW  = (NBPTS-1)*IDIMP1
                        DO 204 IC=1,IDIM
                           XTT1 = XCOOR(IREF+IC)
                           CALL VARIFO(MLREE1.PROG,MLREE2.PROG,NBPOIX,
     &                                 JORDO,XTT1, YTT1)
c* ??                           XCOOR(INEW+IC) = XTT1*YTT1
                           XCOOR(INEW+IC) = YTT1
 204                    CONTINUE
                        XCOOR(INEW+IDIMP1) = XCOOR(IREF+IDIMP1)
                        IELCHE(IGAU,IB) = NBPTS
 203              CONTINUE
                  SEGACT,MCOORD
               ELSE
*
*                 TYPE DE COMPOSANTE NON RECONNU
*
                  MOTERR(1:8) = MCHAM1.NOMCHE(ICOMP)
                  CALL ERREUR(679)
                  SEGSUP,MELVA1,MCHAM1,MCHEL1
                  SEGDES,MELVAL
                  GOTO 999
               ENDIF
            ELSE
               DO 300 IB = 1, N1EL
                  DO 300 IGAU = 1, N1PTEL
                     XTT1 = MELVAL.VELCHE(IGAU,IB)
                     CALL VARIFO(MLREE1.PROG,MLREE2.PROG,NBPOIX,
     &                           JORDO,XTT1, YTT1)
                     MELVA1.VELCHE(IGAU,IB) = YTT1
 300           CONTINUE
            ENDIF
            SEGDES,MELVA1,MELVAL
 200     CONTINUE
         SEGDES,MCHAM1
 100  CONTINUE
      SEGDES,MCHEL1
 
      IPCHMU = MCHEL1
      IRET = 1
*
 999  CONTINUE
      SEGDES,MLREE1,MLREE2
 
      RETURN
      END