Sources Esope | Cast3M

actich
C ACTICH    SOURCE    OF166741  25/02/21    21:15:02     12166          
 
C--------------------------------------------------------------------
C          ACCELERATION SUR UNE COMPOSANTE D'UN CHAMELEM
C--------------------------------------------------------------------
      SUBROUTINE ACTICH(FLOT,IPCH1,IPCH2,IPCH3,MACOMP,IPCH4)
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
 
-INC SMCHAML
-INC TMPTVAL
 
      SEGMENT NOMID
        CHARACTER*8 LESOBL(NBROBL),LESFAC(NBRFAC)
      ENDSEGMENT
 
      SEGMENT NOTYPE
        CHARACTER*16 TYPE(NBTYPE)
      ENDSEGMENT
 
      CHARACTER*(LOCOMP) MACOMP
 
      PARAMETER ( NINF=3 )
      INTEGER INFOS(NINF)
      CHARACTER*16 MOT1,MOT2,MOT3
      CHARACTER*(nconch) CONM
 
      MCHEL1 = IPCH1
      MCHEL2 = IPCH2
      MCHEL3 = IPCH3
      SEGACT,MCHEL1,MCHEL2,MCHEL3
 
      MOT1 = MCHEL1.TITCHE
      MOT2 = MCHEL2.TITCHE
      MOT3 = MCHEL3.TITCHE
      IF (MOT1.NE.MOT2.OR.MOT1.NE.MOT3) THEN
        CALL ERREUR(253)
        GOTO 666
      ENDIF
*
*     Verification  du lieu support des MCHAMLs
*
      CALL QUESUP(0,IPCH1,0,0,ISUP1,IRET1)
      IF (IERR.NE.0) GOTO 666
      CALL QUESUP(0,IPCH2,0,0,ISUP2,IRET2)
      IF(IERR.NE.0) GOTO 666
      CALL QUESUP(0,IPCH3,0,0,ISUP3,IRET3)
      IF(IERR.NE.0) GOTO 666
      IF((ISUP1.EQ.ISUP2.AND.ISUP1.EQ.ISUP3)
     1            .OR.
     1  ((ISUP1.EQ.0.AND.ISUP2.EQ.0).OR.
     1   (ISUP2.EQ.0.AND.ISUP3.EQ.0).OR.
     1   (ISUP3.EQ.0.AND.ISUP1.EQ.0))
     1           .OR.
     1  ((ISUP1.EQ.0.AND.ISUP2.EQ.ISUP3).OR.
     1   (ISUP2.EQ.0.AND.ISUP3.EQ.ISUP1).OR.
     1   (ISUP3.EQ.0.AND.ISUP1.EQ.ISUP2)))THEN
        IOK=1
      ELSE
        IOK=0
        MOTERR(1:8)=MOT1
        CALL ERREUR(124)
        GOTO 666
      ENDIF
C
C   ON COPIE LE TROISIEME MCHAML
C
      CALL COPIE8(IPCH3,IPCH4)
      MCHEL4=IPCH4
      SEGACT,MCHEL4
      NSOU4=MCHEL4.IMACHE(/1)
C
C     BOUCLE SUR LES ZONES
C
      DO 500 ISOUS=1,NSOU4
C
      IPMAIL=MCHEL4.IMACHE(ISOUS)
      CONM=MCHEL4.CONCHE(ISOUS)
C
C     CREATION DU TABLEAU INFOS
C
      CALL IDENT(IPMAIL,CONM,IPCH1,IPCH2,INFOS,IRTD)
      IF (IRTD.EQ.0) THEN
        SEGDES MCHEL4
        CALL DTCHAM(IPCH4)
        GOTO 666
      ENDIF
C
      MCHAML=MCHEL4.ICHAML(ISOUS)
      SEGACT MCHAML
      NCOMP=IELVAL(/1)
      NBROBL=NCOMP
      NBRFAC=0
      SEGINI NOMID
      MONOM=NOMID
      NBTYPE=NCOMP
      SEGINI NOTYPE
      MOTYPE=NOTYPE
        DO IC=1,NCOMP
          LESOBL(IC)=NOMCHE(IC)
          TYPE(IC)=TYPCHE(IC)
        ENDDO
C
        IF (NCOMP.EQ.1) THEN
          NUMCO=1
        ELSE
          NUMCO=0
          DO IC=1,NCOMP
            IF (MACOMP.EQ.NOMCHE(IC)) THEN
              NUMCO=IC
              GOTO 30
            ENDIF
          ENDDO
 30       CONTINUE
        ENDIF
        IF(NUMCO.EQ.0)THEN
          MOTERR(1:4)=MACOMP
          CALL ERREUR(243)
          CALL DTCHAM(IPCH4)
          GO TO 666
        ENDIF
C
C     ON VERIFIE SI ON A LES MEMES COMPOSANTES SUR LES AUTRES
C     CHAMPS ET ON LES EXTRAIT
C
      CALL KOMCHA(IPCH1,IPMAIL,CONM,MONOM,MOTYPE,1,INFOS,3,IVACH1)
      IF(IERR.NE.0)THEN
        SEGSUP NOMID,NOTYPE
        CALL DTMVAL(IVACH1,1)
        CALL DTCHAM(IPCH4)
        GO TO 666
       ENDIF
      CALL KOMCHA(IPCH2,IPMAIL,CONM,MONOM,MOTYPE,1,INFOS,3,IVACH2)
      IF(IERR.NE.0)THEN
        SEGSUP NOMID,NOTYPE
        CALL DTMVAL(IVACH1,1)
        CALL DTMVAL(IVACH2,1)
        CALL DTCHAM(IPCH4)
        GO TO 666
       ENDIF
      CALL KOMCHA(IPCH3,IPMAIL,CONM,MONOM,MOTYPE,1,INFOS,3,IVACH3)
      SEGSUP NOMID,NOTYPE
C
      MELVAL=IELVAL(NUMCO)
      SEGACT,MELVAL
      NBPTE4=VELCHE(/1)
      NEL4  =VELCHE(/2)
      MPTVAL=IVACH1
      MELVAL=IVAL(NUMCO)
      NBPTE1=VELCHE(/1)
      NEL1  =VELCHE(/2)
      MPTVAL=IVACH2
      MELVAL=IVAL(NUMCO)
      NBPTE2=VELCHE(/1)
      NEL2  =VELCHE(/2)
      NBPTEL=MAX(MAX(NBPTE1,NBPTE2),NBPTE4)
      NBELEM=MAX(MAX(NEL1,NEL2),NEL4)
      N1PTEL=NBPTEL
      N1EL=NBELEM
      N2PTEL=0
      N2EL=0
      MELVAL=IELVAL(NUMCO)
      IF(N1PTEL.GT.NBPTE4.OR.N1EL.GT.NEL4)SEGADJ MELVAL
C
      DO 100 IB=1,NBELEM
        DO 100 IGAU=1,NBPTEL
C
          MPTVAL=IVACH1
          MELVAL=IVAL(NUMCO)
          IGMN=MIN(IGAU,VELCHE(/1))
          IBMN=MIN(IB,VELCHE(/2))
          V1=VELCHE(IGMN,IBMN)
C
          MPTVAL=IVACH2
          MELVAL=IVAL(NUMCO)
          IGMN=MIN(IGAU,VELCHE(/1))
          IBMN=MIN(IB,VELCHE(/2))
          V2=VELCHE(IGMN,IBMN)
C
          MPTVAL=IVACH3
          MELVAL=IVAL(NUMCO)
          IGMN=MIN(IGAU,VELCHE(/1))
          IBMN=MIN(IB,VELCHE(/2))
          V3=VELCHE(IGMN,IBMN)
C
          RR=V3
          RD=V2-V1
          IF(RD.EQ.0.D0) GO TO 50
          RAI=(V3-V2)/RD
          IF(ABS(RAI).GT.FLOT) GO TO 50
          IF(RAI.EQ.1.D0) GO TO 50
          RR=V3+(V3-V2)*RAI/(1.D0-RAI)
   50     CONTINUE
          MELVAL=IELVAL(NUMCO)
          VELCHE(IGAU,IB)=RR
  100  CONTINUE
C
C    DESACTIVATION DES SEGMENTS
C
C
        CALL DTMVAL(IVACH1,1)
C
        CALL DTMVAL(IVACH2,1)
C
        CALL DTMVAL(IVACH3,1)
C
          MELVAL=IELVAL(NUMCO)
          SEGDES MELVAL
          SEGDES MCHAML
C
  500  CONTINUE
        SEGDES MCHEL4
 
 666   CONTINUE
       SEGDES MCHEL1,MCHEL2,MCHEL3
 
       RETURN
       END