Sources Esope | Cast3M

dedu1
C DEDU1     SOURCE    CB215821  20/11/25    13:24:21     10792          
C DEDU1
C
C IDENTIFIE LE CHPOINT MCHPO4 PERMETTANT DE PASSER D'UNE GEOMETRIE
C    IPT1 A UNE SECONDE IPT2 ET POINTE LES NOEUDS DE IPT1 DANS ICP1
C    ITABEL ET INOUVEL ENREGISTRENT LA CORRESPONDANCE POUR LES MELEME
C  FINALEMENT, MCHPO4 RANGE DANS IPOIN1
C APPELE PAR PROPER, POUR EXECUTION OPTIONS 'TRANS' ET 'ROTA' DE DEDU
C
C  11/97 : KICH
C---------------------------------------------------------------------
      SUBROUTINE DEDU1(IPT1,IPT2,ICP1,ITABEL,INOUVEL,IPOIN1)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
-INC SMCOORD
-INC SMELEME
-INC SMCHPOI
      SEGMENT ICP1(nbpts)
      SEGMENT ITABEL(0)
      SEGMENT INOUVEL(0)
 
      SEGINI ITABEL,INOUVEL
      SEGINI ICP1
      SEGDES ICP1
      SEGACT IPT1,IPT2
      NBSOUS1 = IPT1.LISOUS(/1)
      NBSOUS2 = IPT2.LISOUS(/1)
      NBREF1 = IPT1.LISREF(/1)
      NBREF2 = IPT2.LISREF(/1)
      IF (NBSOUS1.NE.NBSOUS2) GOTO 5397
C pas de verification sur les references. kich
c      IF (NBREF1.NE.NBREF2) GOTO 5397
      IF (NBSOUS1.EQ.0) THEN
        IF (IPT1.ITYPEL.NE.IPT2.ITYPEL) GOTO 5397
        IF (IPT1.NUM(/1).NE.IPT2.NUM(/1)) GOTO 5397
        IF (IPT1.NUM(/2).NE.IPT2.NUM(/2)) GOTO 5397
        SEGDES IPT1,IPT2
        CALL PROCHP(IPT1,IPT2,IPOIN1,ICP1)
        IF (IERR.NE.0) GOTO 5397
        ITABEL(**) = IPT1
        INOUVEL(**) = IPT2
      ELSE IF (NBSOUS1.NE.0) THEN
        DO 5310 J=1,NBSOUS1
           IPT3 = IPT1.LISOUS(J)
           IPT4 = IPT2.LISOUS(J)
           SEGACT IPT3,IPT4
           NBSOUS3 = IPT3.LISOUS(/1)
           NBSOUS4 = IPT4.LISOUS(/1)
           NBREF3 = IPT3.LISREF(/1)
           NBREF4 = IPT4.LISREF(/1)
           IF (NBSOUS3.NE.NBSOUS4) GOTO 5396
C pas de verification sur les references. kich
c           IF (NBREF3.NE.NBREF4) GOTO 5396
           IF (IPT3.ITYPEL.NE.IPT4.ITYPEL) GOTO 5396
           IF (IPT3.NUM(/1).NE.IPT4.NUM(/1)) GOTO 5396
           IF (IPT3.NUM(/2).NE.IPT4.NUM(/2)) GOTO 5396
           SEGDES IPT3,IPT4
           CALL PROCHP(IPT3,IPT4,MCHPO4,ICP1)
           IF (IERR.NE.0) GOTO 5396
           ITABEL(**) = IPT3
           INOUVEL(**) = IPT4
           IF(J.EQ.1) THEN
             IPCHP0 = MCHPO4
           ELSE
             CALL FUCHPO(IPCHP0,MCHPO4,IPRET)
             IPCHP0 = IPRET
           ENDIF
           IF (IERR.NE.0) GOTO 5396
 5310   CONTINUE
        IPOIN1 = IPCHP0
        IF ((NBREF1.NE.0).AND.(NBREF1.EQ.NBREF2)) THEN
          DO 5317 J=1,NBREF1
            DO 5316 K=1,ITABEL(/1)
              IF (ITABEL(K).EQ.IPT1.LISREF(J)) GOTO 5317
 5316         CONTINUE
              ITABEL(**) = IPT1.LISREF(J)
              INOUVEL(**) = IPT2.LISREF(J)
 5317     CONTINUE
        ENDIF
        SEGDES IPT1,IPT2
      ENDIF
      SEGDES ICP1,ITABEL,INOUVEL
      RETURN
 
 5396 CONTINUE
      SEGDES IPT3,IPT4
 5397 CONTINUE
      SEGDES IPT1,IPT2
      SEGSUP ITABEL,INOUVEL,ICP1
*  erreur dans le calcul du CHPOINT, verifier les donnees
      CALL ERREUR(878)
      RETURN
      END