Télécharger la plaquette Cast3M


fr en

Télécharger reduir.eso

Retour à la liste

Numérotation des lignes : 

reduir

  1. C REDUIR    SOURCE    CB215821  20/11/25    13:38:52     10792          
  2.       SUBROUTINE REDUIR(ICHP,IMEL,IRET)
  3. C ======================================================================
  4. C REDUIT LE CHPOINT ICHP AUX POINTS CONTENUS DANS LE MELEME IMEL.LE
  5. C RESULTAT IRET EST UN MELEME.
  6. C ATTENTION : ON A DUPLIQUE LA GEOMETRIE ET LE MPOVAL DANS TOUS LES CAS
  7. C=======================================================================
  8.  
  9.       IMPLICIT INTEGER(I-N)
  10.       IMPLICIT REAL*8 (a-h,o-z)
  11.  
  12. -INC PPARAM
  13. -INC CCOPTIO
  14. -INC SMCHPOI
  15. -INC SMELEME
  16. -INC SMCOORD
  17.  
  18.       SEGMENT ICPR(nbpts)
  19.       SEGMENT/ITRAV/(ITRAV1(NNOE),ITRAV2(NSOUP))
  20.  
  21.       SEGINI ICPR
  22.       IRET=0
  23.       MELEME=IMEL
  24.       SEGACT MELEME
  25.       IKI=0
  26.       NBSOUS=LISOUS(/1)
  27.       IPT1=MELEME
  28.       DO 4 ISOU=1,MAX(1,NBSOUS)
  29.        IF (NBSOUS.NE.0) THEN
  30.        IPT1=LISOUS(ISOU)
  31.        SEGACT IPT1
  32.       ENDIF
  33.       NBNN=IPT1.NUM(/1)
  34.       NBELEM=IPT1.NUM(/2)
  35.       DO 6 I1=1,NBELEM
  36.       DO 7 I2=1,NBNN
  37.       IP1=IPT1.NUM(I2,I1)
  38.       IF(ICPR(IP1).NE.0) GO TO 7
  39.       IKI=IKI+1
  40.       ICPR(IP1)=IKI
  41.  7    CONTINUE
  42.  6    CONTINUE
  43.  4    CONTINUE
  44.       NNOE=IKI
  45. C
  46.       MCHPOI=ICHP
  47.       SEGACT MCHPOI
  48.       NSOUP=IPCHP(/1)
  49.       NSOUPO=0
  50.       NBNN=1
  51.       NBSOUS=0
  52.       NBREF=0
  53.       SEGINI ITRAV
  54.       DO 1 ISOU=1,NSOUP
  55.       NBELEM=0
  56.       MSOUPO=IPCHP(ISOU)
  57.       SEGACT MSOUPO
  58.       MELEME=IGEOC
  59.       SEGACT MELEME
  60.       N2=NUM(/2)
  61.       DO 2 I=1,N2
  62.       IF(ICPR(NUM(1,I)).EQ.0) GO TO 2
  63.       NBELEM=NBELEM+1
  64.        IF (NBELEM.GT.NNOE) CALL ERREUR(476)
  65.        IF (IERR.NE.0) RETURN
  66.       ITRAV1(NBELEM)=I
  67.  2    CONTINUE
  68.       IF(NBELEM.EQ.0) GOTO 3
  69.       MPOVAL=IPOVAL
  70.       SEGACT MPOVAL
  71.       NC=VPOCHA(/2)
  72.       N=NBELEM
  73.       SEGINI MPOVA1
  74.       SEGINI IPT1
  75.       IPT1.ITYPEL=1
  76.       DO 17 I=1,NBELEM
  77.       IP1=ITRAV1(I)
  78.       IPT1.NUM(1,I)=NUM(1,IP1)
  79.       DO 8 IC=1,NC
  80.       MPOVA1.VPOCHA(I,IC)=VPOCHA(IP1,IC)
  81.  8    CONTINUE
  82.  17   CONTINUE
  83.       IPT11=IPT1
  84.       CALL CRECH1(IPT1,1)
  85.       SEGINI MSOUP1
  86.       MSOUP1.IGEOC=IPT1
  87.       MSOUP1.IPOVAL=MPOVA1
  88.       IF (IPT11.NE.IPT1) THEN
  89.          IPT1=IPT11
  90.          SEGSUP,IPT1
  91.       ENDIF
  92.       DO 9 IC=1,NC
  93.       MSOUP1.NOCOMP(IC)=NOCOMP(IC)
  94.       MSOUP1.NOHARM(IC)=NOHARM(IC)
  95.  9    CONTINUE
  96.       NSOUPO=NSOUPO+1
  97.       ITRAV2(NSOUPO)=MSOUP1
  98.  3    CONTINUE
  99.  1    CONTINUE
  100.       SEGSUP ICPR
  101.       NAT=JATTRI(/1)
  102.       SEGINI MCHPO1
  103.       DO 10 I=1,NAT
  104.         MCHPO1.JATTRI(I)=JATTRI(I)
  105.  10   CONTINUE
  106.       DO 11 I=1,NSOUPO
  107.         MCHPO1.IPCHP(I)=ITRAV2(I)
  108.  11   CONTINUE
  109.       MCHPO1.IFOPOI=IFOPOI
  110.       MCHPO1.MTYPOI=MTYPOI
  111.       MCHPO1.MOCHDE=MOCHDE
  112.       IRET=MCHPO1
  113.  5000 CONTINUE
  114.       SEGSUP ITRAV
  115.       END
  116.  
  117.  
  118.  
  119.  
  120.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales