Télécharger la plaquette Cast3M


fr en

Télécharger liaiso.eso

Retour à la liste

Numérotation des lignes : 

liaiso

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

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