Télécharger la plaquette Cast3M


fr en

Télécharger raccor.eso

Retour à la liste

Numérotation des lignes : 

raccor

  1. C RACCOR    SOURCE    CB215821  26/08/24    21:18:04     12622          
  2. C  FABRIQUE LES ELEMENTS RACCORD ENTRE DEUX LIGNES
  3. C  EXTRAIT DE COCO
  4. C
  5.       SUBROUTINE RACCOR(IPT1,IPT2,MELEME,PREC)
  6.  
  7.       IMPLICIT INTEGER(I-N)
  8.       IMPLICIT REAL*8(A-H,O-Z)
  9.  
  10. -INC PPARAM
  11. -INC CCOPTIO
  12. -INC CCGEOME
  13. -INC CCREEL
  14. *-
  15. -INC SMELEME
  16. -INC SMCOORD
  17.       SEGMENT MTRAV
  18.         REAL*8 TA(NBELEM)
  19.         INTEGER NP1(NBELE1),NP2(NBELE1)
  20.       ENDSEGMENT
  21. C* DIMENSION ITEST(0:NBCOUL-1) - NBCOUL stocke dans CCGEOME
  22.       DIMENSION ITEST(0:30)
  23.  
  24.       SEGACT,MCOORD
  25.       IDIMP1 = IDIM+1
  26.  
  27.       PREC3=3.*PREC
  28.       TMAX=-XGRAND
  29.       TMIN= XGRAND
  30.  
  31.       NB1=IPT1.NUM(/2)
  32.       NB2=IPT2.NUM(/2)
  33.       NBMAX=MIN(NB1,NB2)
  34.       NBNN=IPT1.NUM(/1)
  35.       IF (NBNN.NE.IPT2.NUM(/1)) THEN
  36.         CALL ERREUR(16)
  37.         RETURN
  38.       ENDIF
  39.       DO 40 I=0,NBCOUL-1
  40.       ITEST(I)=0
  41.    40 CONTINUE
  42.        DO 41 I=1,NB1
  43.               ITEST(IPT1.ICOLOR(I))=1
  44.   41   CONTINUE
  45.        DO 42 I=1,NB2
  46.               ITEST(IPT2.ICOLOR(I))=1
  47.   42   CONTINUE
  48.       ICHCOL=-1
  49.       DO 43 I=0,NBCOUL-1
  50.        IF (ITEST(I).EQ.1) THEN
  51.         IF (ICHCOL.EQ.-1) THEN
  52.               ICHCOL=I
  53.         ELSE
  54.               ICHCOL=ITABM(ICHCOL,I)
  55.         ENDIF
  56.        ENDIF
  57.  43   CONTINUE
  58.       NBELEM=NB2
  59.       NBELE1=NBELEM+1
  60.       SEGINI MTRAV
  61.       DO 11 I=1,NB2
  62.       Z=0.
  63.       DO 12 J=1,NBNN
  64.       IREF=IPT2.NUM(J,I)*IDIMP1-IDIM
  65.       Z=Z+ABS(XCOOR(IREF))+ABS(XCOOR(IREF+1))
  66.       IF (IDIM.NE.2) Z=Z+ABS(XCOOR(IREF+2))
  67.   12  CONTINUE
  68.       Z=Z/NBNN
  69.       TA(I)=Z
  70.       IF(Z.GT.TMAX) TMAX=Z
  71.       IF(Z.LT.TMIN) TMIN=Z
  72.    11 CONTINUE
  73. C
  74. C  CLASSEMENT APPROXIMATIF PAR ' DISTANCE '
  75. C
  76.       IF ((ABS(TMAX).GE.XPETIT).AND.(TMAX-TMIN)/TMAX.GE.1E-6) GOTO 6
  77.       TMAX=TMAX+1.
  78.       TMIN=TMIN-1.
  79.    6  CONTINUE
  80.       TDEC=(TMAX-TMIN)/NBELEM*1.0001
  81.       N =int( PREC/TDEC) + 1
  82. C* Boucle 3 redeondante avec SEGINI MTRAV
  83. C*      DO 3 I=1,NBELE1
  84. C*    3 NP1(I)=0
  85.       DO 4 I=1,NBELEM
  86.       IPLA=int((TA(I)-TMIN)/TDEC)+1
  87.       NP1(IPLA)=NP1(IPLA)+1
  88.     4 CONTINUE
  89.       DO 400 I=2,NBELE1
  90.       NP1(I)=NP1(I-1)+NP1(I)
  91.   400 CONTINUE
  92.       DO 5 I=1,NBELEM
  93.       IPLA=int((TA(I)-TMIN)/TDEC)+1
  94.       IPLB=NP1(IPLA)
  95.       NP1(IPLA)=NP1(IPLA)-1
  96.       NP2(IPLB)=I
  97.     5 CONTINUE
  98. C
  99. C   DANS NP1 ADDRESSE DU DEBUT DE ZONE
  100. C   DANS NP2 NUMERO DES ELEMENTS  EN NUMEROTATION  LOCALE
  101. C DANS TA  DISTANCE DES ELEMENTS
  102. C
  103. C   IL FAUT PREPARER LE SEGMENT TAMPON OU METTRE LES ELEMS CREES.
  104.       NBREF=0
  105.       NBSOUS=0
  106.       NBNNOR=NBNN
  107.       NBNN=2*NBNN
  108.       NBELEM=NB1+NB2
  109.       SEGINI MELEME
  110.       IPT4=MELEME
  111.       NBT=NBELEM
  112.       NBELEM=NB2
  113.       NUMELG=0
  114. C
  115. C BOUCLE SUR TOUS LES ELEMENTS POUR CONNAITRE LEUR FACES ET REGARDER SI
  116. C LE CENTRE DE GRAVITE EST CONFONDU A PREC PRES DE CELUI D'UN ELEMENT
  117. C  COQUE
  118.       DO 20 I=1,NB1
  119.       ZAA=0.
  120.       DO 21 J=1,NBNNOR
  121.       IREF=IPT1.NUM(J,I)*IDIMP1-IDIM
  122.       ZAA=ZAA+ABS(XCOOR(IREF))+ABS(XCOOR(IREF+1))
  123.       IF (IDIM.NE.2) ZAA=ZAA+ABS(XCOOR(IREF+2))
  124.    21 CONTINUE
  125.       ZAA=ZAA/NBNNOR
  126.       IZO=int((ZAA-TMIN)/TDEC)+1
  127.       IZO1=IZO-N
  128.       IZO2=IZO+N
  129.       IF(IZO1.LT.1) IZO1=1
  130.       IF(IZO2.GT.NBELEM) IZO2=NBELEM
  131.       IF (IZO.LT.0.OR.IZO.GT.NBELE1) GOTO 20
  132.       DO 28 IZO=IZO1,IZO2
  133.       IDEP=NP1(IZO)+1
  134.       IFIN=NP1(IZO+1)
  135.       IF(IFIN.LT.IDEP)  GO TO 28
  136.       DO 23 JFA=IDEP,IFIN
  137.       IB=NP2(JFA)
  138.       IF(ABS(TA(IB)-ZAA).GT.PREC3)  GO TO 23
  139. C  ON VIENT D'IDENTIFIER UN ELEMENT DE RACCOR ON VA LE CREER
  140.       IREFA=IPT1.NUM(1,I)*IDIMP1-IDIM
  141.       DO 24 IK=1,NBNNOR
  142.       IREFB=IPT2.NUM(IK,IB)*IDIMP1-IDIM
  143.       IF (ABS(XCOOR(IREFA)-XCOOR(IREFB)).GT.PREC) GOTO 24
  144.       IF (ABS(XCOOR(1+IREFA)-XCOOR(1+IREFB)).GT.PREC) GOTO 24
  145.       IF (ABS(XCOOR(2+IREFA)-XCOOR(2+IREFB)).GT.PREC.AND.IDIM.NE.2) GOTO
  146.      #  24
  147.       ISTA=IK
  148.       GO TO 26
  149.   24  CONTINUE
  150.       GO TO 23
  151.   26  CONTINUE
  152.       ISENS=1
  153.       ISTA1=ISTA+1
  154.       ISTAA=ISTA
  155.       IF (ISTA1.GT.NBNNOR) ISTA1=1
  156.       IREFA=IPT1.NUM(2,I)*IDIMP1-IDIM
  157.       IREFB=IPT2.NUM(ISTA1,IB)*IDIMP1-IDIM
  158.       Z=XCOOR(IREFA)-XCOOR(IREFB)
  159.       IF(ABS(Z).GT.PREC) ISENS=-1
  160.       Z=XCOOR(IREFA+1)-XCOOR(IREFB+1)
  161.       IF(ABS(Z).GT.PREC) ISENS=-1
  162.       IF (IDIM.NE.2) THEN
  163.         Z=XCOOR(IREFA+2)-XCOOR(IREFB+2)
  164.         IF (ABS(Z).GT.PREC)  ISENS=-1
  165.       ENDIF
  166.       DO 30 IJ=2,NBNNOR
  167.       IREFA=IPT1.NUM(IJ,I)*IDIMP1-IDIM
  168.       ISTAA=ISTAA+ISENS
  169.       IF (ISTAA.EQ.0) ISTAA=NBNNOR
  170.       IF (ISTAA.GT.NBNNOR) ISTAA=1
  171.       IREFB=IPT2.NUM(ISTAA,IB)*IDIMP1-IDIM
  172.       DO 32 KLP=1,IDIM
  173.       Z=XCOOR(IREFA+KLP-1)-XCOOR(IREFB+KLP-1)
  174.       IF(ABS(Z).GT.PREC) GO TO 23
  175.    32 CONTINUE
  176.    30 CONTINUE
  177. C   CREATION D'UN ELEM RACCORD
  178.       NUMELG=NUMELG+1
  179.       IF (NUMELG.GT.NBMAX) CALL ERREUR(31)
  180.       IF (IERR.NE.0) GOTO 101
  181.       DO 27 IK=1,NBNNOR
  182.       IP1=IPT1.NUM(IK,I)
  183.       IP2=IPT2.NUM(ISTA,IB)
  184.       NUM(IK,NUMELG)=IP1
  185.       NUM(NBNN-IK+1,NUMELG)=IP2
  186.       ISTA=ISTA+ISENS
  187.       IF (ISTA.EQ.0) ISTA=NBNNOR
  188.       IF (ISTA.GT.NBNNOR) ISTA=1
  189.       IF (IP1.NE.IP2) GOTO 27
  190.       INTERR(1)=NUMELG
  191.       CALL ERREUR(101)
  192.   27  CONTINUE
  193.    23 CONTINUE
  194.    28 CONTINUE
  195.    20 CONTINUE
  196.       WRITE(IOIMP,29) NUMELG
  197.    29 FORMAT(//,' NOMBRE D''ELEMENTS DE RACCORD CREES : ',I5)
  198.       NBELEM=NUMELG
  199.       MELEME = 0
  200.       IF (NBELEM.EQ.0) THEN
  201.         CALL ERREUR(26)
  202.         GOTO 101
  203.       ENDIF
  204.       SEGINI MELEME
  205.       IF (NBNN.EQ.4) ITYPEL=12
  206.       IF (NBNN.EQ.6) ITYPEL=13
  207.       DO 401 J=1,NBELEM
  208.       ICOLOR(J)=ICHCOL
  209.       DO 100 I=1,NBNN
  210.       NUM(I,J)=IPT4.NUM(I,J)
  211.  100  CONTINUE
  212.   401 CONTINUE
  213.  101  SEGSUP IPT4
  214.       SEGSUP MTRAV
  215.  
  216.       RETURN
  217.       END
  218.  
  219.  
  220.  
  221.  
  222.  
  223.  
  224.  

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