Télécharger la plaquette Cast3M


fr en

Télécharger racpor.eso

Retour à la liste

Numérotation des lignes : 

racpor

  1. C RACPOR    SOURCE    CB215821  26/08/24    21:18:05     12622          
  2. C
  3. C  FABRIQUE LES ELEMENTS RACCORD POUR LES ELEMENTS JOINT POREUX (BALD).
  4. C  CES ELEMENTS JOINTS SONT COMPOSES PAR TROIS LIGNES: LES LIGNES TOP
  5. C  ET BOT SONT MAILLEES AVEC DES ELEMENTS SEG3, LA LIGNE AU MILIEU AVEC
  6. C  DES SEG2. L'ELEMENT RACCORD CREE A 8 NOEUDS.
  7. C
  8.       SUBROUTINE RACPOR(IPT1,IPT2,IPT3,MELEME,PREC)
  9.       IMPLICIT INTEGER(I-N)
  10.       IMPLICIT REAL*8(A-H,O-Z)
  11.  
  12. -INC PPARAM
  13. -INC CCOPTIO
  14. -INC CCGEOME
  15. -INC CCREEL
  16. -INC SMELEME
  17. -INC SMCOORD
  18.       SEGMENT MTRAV
  19.         REAL*8 TA(NBELEM)
  20.         INTEGER NP1(NBELE1),NP2(NBELE1)
  21.       ENDSEGMENT
  22. C* DIMENSION ITEST(0:NBCOUL-1) - NBCOUL stocke dans CCGEOME
  23.       DIMENSION ITEST(0:30)
  24.  
  25.       IDIMP1 = IDIM+1
  26.       SEGACT MCOORD
  27.       PREC3=3.*PREC
  28.       TMAX=-XGRAND
  29.       TMIN= XGRAND
  30.       NB1=IPT1.NUM(/2)
  31.       NB2=IPT2.NUM(/2)
  32.       NB3=IPT3.NUM(/2)
  33.       NBMAX=MIN(NB1,NB2,NB3)
  34.       NBNN=IPT1.NUM(/1)
  35.       NBNM=IPT3.NUM(/1)
  36.       IF ((NBNN.NE.IPT2.NUM(/1)).OR.(NBNN.EQ.NBNM).OR.
  37.      .    (NBSOM(IPT1.ITYPEL).NE.NBSOM(IPT3.ITYPEL))) THEN
  38.         CALL ERREUR(16)
  39.         RETURN
  40.       ENDIF
  41.       DO 40 I=0,(NBCOUL-1)
  42.              ITEST(I)=0
  43.  40   CONTINUE
  44.        DO 41 I=1,NB1
  45.               ITEST(IPT1.ICOLOR(I))=1
  46.   41   CONTINUE
  47.        DO 42 I=1,NB2
  48.               ITEST(IPT2.ICOLOR(I))=1
  49.   42   CONTINUE
  50.        DO 43 I=1,NB3
  51.               ITEST(IPT3.ICOLOR(I))=1
  52.   43   CONTINUE
  53.       ICHCOL=-1
  54.       DO 44 I=0,(NBCOUL-1)
  55.        IF (ITEST(I).EQ.1) THEN
  56.         IF (ICHCOL.EQ.-1) THEN
  57.               ICHCOL=I
  58.         ELSE
  59.               ICHCOL=ITABM(ICHCOL,I)
  60.         ENDIF
  61.        ENDIF
  62.  44   CONTINUE
  63.       NBELEM=NB2
  64.       NBELE1=NBELEM+1
  65.       SEGINI MTRAV
  66.       DO 11 I=1,NB2
  67.       Z=0.
  68.       DO 12 J=1,NBNN
  69.       IREF=IPT2.NUM(J,I)*IDIMP1-IDIM
  70.       Z=Z+XCOOR(IREF)+XCOOR(IREF+1)
  71.       IF (IDIM.NE.2) Z=Z+XCOOR(IREF+2)
  72.   12  CONTINUE
  73.       Z=Z/NBNN
  74.       TA(I)=Z
  75.       IF(Z.GT.TMAX) TMAX=Z
  76.       IF(Z.LT.TMIN) TMIN=Z
  77.    11 CONTINUE
  78. C
  79. C  CLASSEMENT APPROXIMATIF PAR ' DISTANCE '
  80. C
  81.       IF (ABS(TMAX).GE.XPETIT) THEN
  82.         IF ((TMAX-TMIN)/TMAX.GE.1E-6) GOTO 6
  83.       ENDIF
  84.       TMAX=TMAX+1.D0
  85.       TMIN=TMIN-1.D0
  86.  
  87.    6  CONTINUE
  88.       TDEC=(TMAX-TMIN)/NBELEM*1.0001D0
  89.       N = PREC/TDEC + 1.D0
  90. C* Boucle 3 redondante avec SEGINI,MTRAV
  91. C*      DO 3 I=1,NBELE1
  92. C*    3 NP1(I)=0
  93.       DO 4 I=1,NBELEM
  94.       IPLA=(TA(I)-TMIN)/TDEC+1.D0
  95.       NP1(IPLA)=NP1(IPLA)+1
  96.     4 CONTINUE
  97.       DO 400 I=2,NBELE1
  98.       NP1(I)=NP1(I-1)+NP1(I)
  99.   400 CONTINUE
  100.       DO 5 I=1,NBELEM
  101.       IPLA=(TA(I)-TMIN)/TDEC+1.D0
  102.       IPLB=NP1(IPLA)
  103.       NP1(IPLA)=NP1(IPLA)-1
  104.       NP2(IPLB)=I
  105.     5 CONTINUE
  106. C
  107. C   DANS NP1 ADDRESSE DU DEBUT DE ZONE
  108. C   DANS NP2 NUMERO DES ELEMENTS  EN NUMEROTATION  LOCALE
  109. C   DANS TA  DISTANCE DES ELEMENTS
  110. C
  111. C   IL FAUT PREPARER LE SEGMENT TAMPON OU METTRE LES ELEMS CREES.
  112.       NBREF=0
  113.       NBSOUS=0
  114.       NBNNOR=NBNN
  115.       NBNN=2*NBNN+NBNM
  116.       NBELEM=NB1+NB2
  117.       SEGINI MELEME
  118.       IPT4=MELEME
  119.       NBT=NBELEM
  120.       NBELEM=NB2
  121.       NUMELG=0
  122. C
  123. C BOUCLE SUR TOUS LES ELEMENTS POUR CONNAITRE LEUR FACES ET REGARDER SI
  124. C LE CENTRE DE GRAVITE EST CONFONDU A PREC PRES DE CELUI D'UN ELEMENT
  125. C COQUE
  126. C
  127.       DO 20 I=1,NB1
  128.       ZAA=0.
  129.       DO 21 J=1,NBNNOR
  130.       IREF=IPT1.NUM(J,I)*IDIMP1-IDIM
  131.       ZAA=ZAA+XCOOR(IREF)+XCOOR(IREF+1)
  132.       IF (IDIM.NE.2) ZAA=ZAA+XCOOR(IREF+2)
  133.    21 CONTINUE
  134.       ZAA=ZAA/NBNNOR
  135.       IZO=(ZAA-TMIN)/TDEC+1.D0
  136.       IZO1=IZO-N
  137.       IZO2=IZO+N
  138.       IF(IZO1.LT.1) IZO1=1
  139.       IF(IZO2.GT.NBELEM) IZO2=NBELEM
  140.       IF (IZO.LT.0.OR.IZO.GT.NBELE1) GOTO 20
  141.       DO 28 IZO=IZO1,IZO2
  142.       IDEP=NP1(IZO)+1
  143.       IFIN=NP1(IZO+1)
  144.       IF(IFIN.LT.IDEP)  GO TO 28
  145.       DO 23 JFA=IDEP,IFIN
  146.       IB=NP2(JFA)
  147.       IF(ABS(TA(IB)-ZAA).GT.PREC3)  GO TO 23
  148.       IREFA=IPT1.NUM(1,I)*IDIMP1-IDIM
  149.       DO 24 IK=1,NBNNOR
  150.       IREFB=IPT2.NUM(IK,IB)*IDIMP1-IDIM
  151.       IF (ABS(XCOOR(IREFA)-XCOOR(IREFB)).GT.PREC) GOTO 24
  152.       IF (ABS(XCOOR(1+IREFA)-XCOOR(1+IREFB)).GT.PREC) GOTO 24
  153.       IF (ABS(XCOOR(2+IREFA)-XCOOR(2+IREFB)).GT.PREC.AND.IDIM.NE.2)
  154.      #    GOTO 24
  155.       ISTA=IK
  156.       GO TO 26
  157.   24  CONTINUE
  158.       GO TO 23
  159.   26  CONTINUE
  160.       ISENS=1
  161.       ISTA1=ISTA+1
  162.       ISTAA=ISTA
  163.       IF (ISTA1.GT.NBNNOR) ISTA1=1
  164.       IREFA=IPT1.NUM(2,I)*IDIMP1-IDIM
  165.       IREFB=IPT2.NUM(ISTA1,IB)*IDIMP1-IDIM
  166.       Z=XCOOR(IREFA)-XCOOR(IREFB)
  167.       IF(ABS(Z).GT.PREC) ISENS=-1
  168.       Z=XCOOR(IREFA+1)-XCOOR(IREFB+1)
  169.       IF(ABS(Z).GT.PREC) ISENS=-1
  170.       IF (IDIM.NE.2) THEN
  171.         Z=XCOOR(IREFA+2)-XCOOR(IREFB+2)
  172.         IF (ABS(Z).GT.PREC)  ISENS=-1
  173.       ENDIF
  174.       DO 30 IJ=2,NBNNOR
  175.       IREFA=IPT1.NUM(IJ,I)*IDIMP1-IDIM
  176.       ISTAA=ISTAA+ISENS
  177.       IF (ISTAA.EQ.0) ISTAA=NBNNOR
  178.       IF (ISTAA.GT.NBNNOR) ISTAA=1
  179.       IREFB=IPT2.NUM(ISTAA,IB)*IDIMP1-IDIM
  180.       DO 32 KLP=1,IDIM
  181.       Z=XCOOR(IREFA+KLP-1)-XCOOR(IREFB+KLP-1)
  182.       IF(ABS(Z).GT.PREC) GO TO 23
  183.    32 CONTINUE
  184.    30 CONTINUE
  185. C
  186.       IZC=(ZAA-TMIN)/TDEC+1.D0
  187.       DO 33 IC=1,NB3
  188.       ZAC=0.
  189.       DO 31 J=1,NBNM
  190.       IREF=IPT3.NUM(J,IC)*IDIMP1-IDIM
  191.       ZAC=ZAC+XCOOR(IREF)+XCOOR(IREF+1)
  192.       IF (IDIM.NE.2) ZAC=ZAC+XCOOR(IREF+2)
  193.    31 CONTINUE
  194.       ZAC=ZAC/NBNM
  195.       IF(ABS(ZAA-ZAC).GT.PREC3)  GO TO 33
  196. C  ON VIENT D'IDENTIFIER UN ELEMENT DE RACCOR ON VA LE CREER
  197.       IREFA=IPT1.NUM(1,I)*IDIMP1-IDIM
  198.       DO 34 IK=1,NBNM
  199.       IREFB=IPT3.NUM(IK,IC)*IDIMP1-IDIM
  200.       IF (ABS(XCOOR(IREFA)-XCOOR(IREFB)).GT.PREC) GOTO 34
  201.       IF (ABS(XCOOR(1+IREFA)-XCOOR(1+IREFB)).GT.PREC) GOTO 34
  202.       IF (ABS(XCOOR(2+IREFA)-XCOOR(2+IREFB)).GT.PREC.AND.IDIM.NE.2)
  203.      #    GOTO 34
  204.       ISTC=IK
  205.       GO TO 36
  206.   34  CONTINUE
  207.       GO TO 33
  208.   36  CONTINUE
  209.       ISENT=1
  210.       ISTC1=ISTC+1
  211.       ISTCC=ISTC
  212.       IF (ISTC1.GT.NBNM) ISTC1=1
  213.       IREFA=IPT1.NUM(3,I)*IDIMP1-IDIM
  214.       IREFB=IPT3.NUM(ISTC1,IC)*IDIMP1-IDIM
  215.       Z=XCOOR(IREFA)-XCOOR(IREFB)
  216.       IF(ABS(Z).GT.PREC) ISENT=-1
  217.       Z=XCOOR(IREFA+1)-XCOOR(IREFB+1)
  218.       IF(ABS(Z).GT.PREC) ISENT=-1
  219.       IF (IDIM.NE.2) THEN
  220.         Z=XCOOR(IREFA+2)-XCOOR(IREFB+2)
  221.         IF (ABS(Z).GT.PREC) ISENT=-1
  222.       ENDIF
  223.       DO 50 IJ=3,NBNNOR,2
  224.       IREFA=IPT1.NUM(IJ,I)*IDIMP1-IDIM
  225.       ISTCC=ISTCC+ISENT
  226.       IF (ISTCC.EQ.0) ISTCC=NBNM
  227.       IF (ISTCC.GT.NBNM) ISTCC=1
  228.       IREFB=IPT3.NUM(ISTCC,IC)*IDIMP1-IDIM
  229.       DO 52 KLP=1,IDIM
  230.       Z=XCOOR(IREFA+KLP-1)-XCOOR(IREFB+KLP-1)
  231.       IF(ABS(Z).GT.PREC) GO TO 33
  232.    52 CONTINUE
  233.    50 CONTINUE
  234. C   CREATION D'UN ELEM RACCORD
  235.       NUMELG=NUMELG+1
  236.       IF (NUMELG.GT.NBMAX) CALL ERREUR(31)
  237.       IF (IERR.NE.0) GOTO 101
  238.       IM=0
  239.       DO 27 IK=1,NBNNOR
  240.       IP1=IPT1.NUM(IK,I)
  241.       IP2=IPT2.NUM(ISTA,IB)
  242.       NUM(IK,NUMELG)=IP1
  243.       NUM(2*NBNNOR-IK+1,NUMELG)=IP2
  244.       ISTA=ISTA+ISENS
  245.       IF (ISTA.EQ.0) ISTA=NBNNOR
  246.       IF (ISTA.GT.NBNNOR) ISTA=1
  247.         IF (IK.EQ.IBSOM(NSPOS(IPT1.ITYPEL)+IM)) THEN
  248.         IM=IM+1
  249.         IP3=IPT3.NUM(ISTC,IC)
  250.         NUM(2*NBNNOR+IM,NUMELG)=IP3
  251.         ISTC=ISTC+ISENT
  252.         IF (ISTC.EQ.0) ISTC=NBNM
  253.         IF (ISTC.GT.NBNM) ISTC=1
  254.         IF ((IP1.NE.IP2).AND.(IP1.NE.IP3).AND.(IP2.NE.IP3)) GO TO 27
  255.         INTERR(1)=NUMELG
  256.         CALL ERREUR(101)
  257.         ENDIF
  258.       IF (IP1.NE.IP2) GO TO 27
  259.       INTERR(1)=NUMELG
  260.       CALL ERREUR(101)
  261.    27 CONTINUE
  262.    33 CONTINUE
  263. C
  264.    23 CONTINUE
  265.    28 CONTINUE
  266.    20 CONTINUE
  267. C      WRITE(IOIMP,29) NUMELG
  268. C   29 FORMAT(//,' NOMBRE D''ELEMENTS DE RACCORD CREES : ',I5)
  269.       MELEME=0
  270.       NBELEM=NUMELG
  271.       IF (NBELEM.EQ.0) THEN
  272.         CALL ERREUR(26)
  273.         GOTO 101
  274.       ENDIF
  275.       SEGINI MELEME
  276.       IF (NBNN.EQ.8) ITYPEL=29
  277.       DO 401 J=1,NBELEM
  278.       ICOLOR(J)=ICHCOL
  279.       DO 100 I=1,NBNN
  280.       NUM(I,J)=IPT4.NUM(I,J)
  281.  100  CONTINUE
  282.   401 CONTINUE
  283.  101  SEGSUP IPT4
  284.       SEGSUP MTRAV
  285.       RETURN
  286.       END
  287.  
  288.  
  289.  

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