Télécharger la plaquette Cast3M


fr en

Télécharger coutur.eso

Retour à la liste

Numérotation des lignes : 

coutur

  1. C COUTUR    SOURCE    GOUNAND   21/03/31    21:15:00     10931          
  2. C   CE SOUS PROGRAMME EFFECTUE LA COUTURE ENTRE DEUX LIGNES
  3. C REPRIS DE COCO
  4. C     
  5. C     SG 2020/04/27 : On ajoute la fonctionnalité d'étoilement à
  6. C     partir d'un point vers un maillage de ligne ou de surface     
  7. C      
  8. C
  9.       SUBROUTINE COUTUR
  10.  
  11.       IMPLICIT INTEGER(I-N)
  12.       IMPLICIT REAL*8 (A-H,O-Z)
  13.  
  14. -INC CCGEOME
  15. -INC PPARAM
  16. -INC CCOPTIO
  17. -INC SMELEME
  18. -INC SMCOORD
  19.  
  20. C     ITEST(0:NBCOUL-1)
  21.  
  22.       DIMENSION ITPOIN(2),ITEST(0:30)
  23.  
  24.       DISTA(A,B,C,D,E,F)=SQRT((A-D)*(A-D)+(B-E)*(B-E)+(C-F)*(C-F))
  25.  
  26.       CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  27.       IF(IERR .NE. 0)RETURN
  28.       CALL ACTOBJ('MAILLAGE',IPT1,1)
  29.       IF(IERR .NE. 0)RETURN
  30.  
  31.       CALL LIROBJ('MAILLAGE',IPT2,0,ILIG2)
  32.       IF(ILIG2 .EQ. 1)THEN
  33.          CALL ACTOBJ('MAILLAGE',IPT2,1)
  34.          IF(IERR .NE. 0)RETURN
  35.       ELSE
  36. C       On tente la lecture d'un POINT
  37.          CALL LIROBJ('POINT   ',IPO2,1,IRETOU)
  38.          IF(IERR.NE.0)RETURN
  39.       ENDIF
  40.  
  41.       IF (ILIG2.EQ.0.AND.IPT1.ITYPEL.NE.3) THEN
  42. *     On effectue un étoilement à partir du point IPO2 avec la
  43. *     subroutine etoilm :
  44. *     Par rapport à l'ancienne sémantique de couture :
  45. *     + IPT1 peut être un maillage complexe de POI1, SEG2, TRI3, QUA4         
  46. *     + gere le cas si IPO2 appartient à IPT1 : on ne genere pas les
  47. *     elements correspondants
  48. *     - ne gere pas le cas SEG3 (celui-ci n'est d'ailleurs pas tres
  49. *     bien gere car il recree les noeuds milieux)
  50. *     - si element surfacique, on ne prend plus LISREF(1) qui est le
  51. *     cote 1 
  52. *
  53.          CALL ETOILM(IPO2,IPT1,IPT3)
  54.          IF (IERR.NE.0) RETURN
  55.          GOTO 999
  56.       ENDIF
  57.  
  58.       IF (IPT1.LISOUS(/1).NE.0) CALL ERREUR(25)
  59.       IF (IERR.NE.0) RETURN
  60.  
  61.       DO 10 I=0,NBCOUL-1
  62.         ITEST(I)=0
  63.  10   CONTINUE
  64.  
  65.       IF (KSURF(IPT1.ITYPEL).EQ.0) THEN
  66.          DO 21 I=1,IPT1.NUM(/2)
  67.             ITEST(IPT1.ICOLOR(I))=1
  68.  21      CONTINUE
  69.          GOTO 1
  70.       ENDIF
  71.       NBREF=IPT1.LISREF(/1)
  72.       IF (NBREF.EQ.0) CALL ERREUR(24)
  73.       IF (NBREF.NE.4) CALL ERREUR(26)
  74.       IF (IERR.NE.0) RETURN
  75.       IPT3=IPT1.LISREF(1)
  76.       CALL INVERS(IPT3,IPT1)
  77.       DO 11 I=1,IPT3.NUM(/2)
  78.               ITEST(IPT3.ICOLOR(I))=1
  79.   11  CONTINUE
  80.    1  CONTINUE
  81.       IF (ILIG2.EQ.0) GOTO 3
  82.       IF (IPT2.LISOUS(/1).NE.0) CALL ERREUR(25)
  83.       IF (IERR.NE.0) RETURN
  84.       IF (KSURF(IPT2.ITYPEL).EQ.0) THEN
  85.        DO 22 I=1,IPT2.NUM(/2)
  86.               ITEST(IPT2.ICOLOR(I))=1
  87.   22   CONTINUE
  88.        GOTO 2
  89.       ENDIF
  90.       NBREF=IPT2.LISREF(/1)
  91.       IF (NBREF.EQ.0) CALL ERREUR(24)
  92.       IF (NBREF.NE.4) CALL ERREUR(26)
  93.       IF (IERR.NE.0) RETURN
  94.       IPT3=IPT2.LISREF(1)
  95.       DO 12 I=1,IPT3.NUM(/2)
  96.               ITEST(IPT3.ICOLOR(I))=1
  97.   12  CONTINUE
  98.       IPT2=IPT3
  99.    2  CONTINUE
  100. C  IPT1 ET IPT2 SONT LES DEUX LIGNES A COUDRE   ELLES SONT DECRITES
  101. C  DANS LE MEME SENS
  102. C  ON VERIFIE D'ABORD LA COHERENCE DES TYPES D'ELEMENTS
  103.       ITY1=IPT1.ITYPEL
  104.       IF (ITY1.NE.IPT2.ITYPEL) CALL ERREUR(16)
  105.       IF ((ITY1 .NE. 2) .AND. (ITY1 .NE. 3)) CALL ERREUR(16)
  106.       IF (IERR.NE.0) RETURN
  107.  
  108. C  ON CREE IPT3 QUI CONTIENT LE RESULTAT
  109.    3  CONTINUE
  110.       ICHCOL=-1
  111.       DO 13 I=0,NBCOUL-1
  112.        IF (ITEST(I).EQ.1) THEN
  113.         IF (ICHCOL.EQ.-1) THEN
  114.               ICHCOL=I
  115.         ELSE
  116.               ICHCOL=ITABM(ICHCOL,I)
  117.         ENDIF
  118.        ENDIF
  119.  13   CONTINUE
  120.       NBELE1=IPT1.NUM(/2)
  121.       NBELE2=0
  122.       NBREF=3
  123.       IF (ILIG2.EQ.0) GOTO 4
  124.       NBREF=4
  125.       NBELE2=IPT2.NUM(/2)
  126.    4  CONTINUE
  127.       NBELEM=NBELE1+NBELE2
  128.       NBNN  =3
  129.       NBSOUS=0
  130.       SEGINI IPT3
  131.       IPT3.ITYPEL=4
  132.       IPT3.LISREF(1)=IPT1
  133.       IF (ILIG2.EQ.0) GOTO 5
  134.       CALL INVERS(IPT2,IPT4)
  135.       IPT3.LISREF(3)=IPT4
  136. C  IL FAUR CREER LES BORDS LATERAUX
  137.    5  CONTINUE
  138.       NBNN  =2
  139.       NBELEM=1
  140.       NBSOUS=0
  141.       NBREF =0
  142.       SEGINI IPT4
  143.       IPT4.ITYPEL=2
  144.       IPT3.LISREF(2)=IPT4
  145.       IPT4.NUM(1,1)=IPT1.NUM(IPT1.NUM(/1),NBELE1)
  146.       IF (ILIG2.NE.0) IPT4.NUM(2,1)=IPT2.NUM(IPT2.NUM(/1),NBELE2)
  147.       IF (ILIG2.EQ.0) IPT4.NUM(2,1)=IPO2
  148.       NBNN  =2
  149.       NBELEM=1
  150.       NBSOUS=0
  151.       NBREF =0
  152.       SEGINI IPT4
  153.       IPT4.ITYPEL=2
  154.       IPT4.NUM(2,1)=IPT1.NUM(1,1)
  155.       IF (ILIG2.EQ.0) GOTO 6
  156.       IPT4.NUM(1,1)=IPT2.NUM(1,1)
  157.       IPT3.LISREF(4)=IPT4
  158.       GOTO 7
  159.    6  IPT4.NUM(1,1)=IPO2
  160.       IPT3.LISREF(3)=IPT4
  161.    7  CONTINUE
  162.       LNUMEL=1
  163.       NBNN=IPT1.NUM(/1)
  164.       IF (ILIG2.EQ.0) GOTO 800
  165. CC
  166. C     COUTURE AVEC DES TRIANGLES A 3 NOEUDS
  167. C     IMAX = NUMERO DU DERNIER ELEMENT DU COTE 1
  168. C     JMAX = NUMERO DU DERNIER ELEMENT DE LA COUTURE
  169. C
  170.       SEGACT,MCOORD
  171.       IMAX = NBELE1
  172.       JMAX = NBELE2
  173.       NUMELG=0
  174.       IEL1=1
  175.       IEL2=1
  176.  100  I1=IPT1.NUM(1,IEL1)
  177.       I2=IPT1.NUM(NBNN,IEL1)
  178.       J1=IPT2.NUM(1,IEL2)
  179.       J2=IPT2.NUM(NBNN,IEL2)
  180.  101  CONTINUE
  181.       IREF1=(I1-1)*(IDIM+1)
  182.       IREF2=(I2-1)*(IDIM+1)
  183.       JREF1=(J1-1)*(IDIM+1)
  184.       JREF2=(J2-1)*(IDIM+1)
  185.       XI1=XCOOR(IREF1+1)
  186.       YI1=XCOOR(IREF1+2)
  187.       ZI1=XCOOR(IREF1+3)
  188.       XI2=XCOOR(IREF2+1)
  189.       YI2=XCOOR(IREF2+2)
  190.       ZI2=XCOOR(IREF2+3)
  191.       XJ1=XCOOR(JREF1+1)
  192.       YJ1=XCOOR(JREF1+2)
  193.       ZJ1=XCOOR(JREF1+3)
  194.       XJ2=XCOOR(JREF2+1)
  195.       YJ2=XCOOR(JREF2+2)
  196.       ZJ2=XCOOR(JREF2+3)
  197.       IF (IDIM.EQ.3) GOTO 200
  198.       ZI1=0
  199.       ZI2=0
  200.       ZJ1=0.
  201.       ZJ2=0.
  202.  200  CONTINUE
  203.       A=DISTA(XI1,YI1,ZI1,XJ2,YJ2,ZJ2)
  204.       B=DISTA(XJ1,YJ1,ZJ1,XI2,YI2,ZI2)
  205.       IF(A.LE.B) GO TO 102
  206. CC
  207. C     DIST(J1,I2) < DIST(I1,J2)
  208. C     ON CREE LE TRIANGLE I1,I2,J1
  209. C
  210.       NUMELG = NUMELG + 1
  211.       IPT3.NUM(1,NUMELG) = I1
  212.       IPT3.NUM(2,NUMELG) = I2
  213.       IPT3.NUM(3,NUMELG) = J1
  214.       INTERR(1)=NUMELG
  215.       IF (I1.EQ.I2.OR.I1.EQ.J1.OR.I2.EQ.J1) CALL ERREUR(101)
  216.       IF(IEL1.EQ.IMAX) GO TO 103
  217.       IEL1=IEL1+1
  218.       GO TO 100
  219. CC
  220. C     PLUS DE POINT SUR LE COTE 1 = ON RELIE I2 AUX POINTS RESTANTS
  221. C     DE LA COUTURE
  222. C
  223.   103 NUMELG = NUMELG + 1
  224.       IPT3.NUM(1,NUMELG) = I2
  225.       IPT3.NUM(2,NUMELG) = J2
  226.       IPT3.NUM(3,NUMELG) = J1
  227.       INTERR(1)=NUMELG
  228.       IF (I2.EQ.J2.OR.I2.EQ.J1.OR.J2.EQ.J1) CALL ERREUR(101)
  229.       IF(IEL2.EQ.JMAX) GO TO 150
  230.       IEL2=IEL2+1
  231.       J1=IPT2.NUM(1,IEL2)
  232.       J2=IPT2.NUM(NBNN,IEL2)
  233.       GO TO 103
  234. CC
  235. C     DIST(J1,I2) > DIST(I1,J2)
  236. C     ON CREE LE TRIANGLE I1,J2,J1
  237. C
  238.   102 NUMELG = NUMELG + 1
  239.       IPT3.NUM(1,NUMELG) = I1
  240.       IPT3.NUM(2,NUMELG) = J2
  241.       IPT3.NUM(3,NUMELG) = J1
  242.       INTERR(1)=NUMELG
  243.       IF (I1.EQ.J2.OR.I1.EQ.J1.OR.J2.EQ.J1) CALL ERREUR(101)
  244.       IF(IEL2.EQ.JMAX) GO TO 105
  245.       IEL2=IEL2+1
  246.       GOTO 100
  247. CC
  248. C     PLUS DE POINT SUR LA COUTURE = ON RELIE J2 AUX POINTS RESTANTS
  249. C     DU COTE 1
  250. C
  251.   105 NUMELG = NUMELG + 1
  252.       IPT3.NUM(1,NUMELG) = I1
  253.       IPT3.NUM(2,NUMELG) = I2
  254.       IPT3.NUM(3,NUMELG) = J2
  255.       INTERR(1)=NUMELG
  256.       IF (I1.EQ.I2.OR.I1.EQ.J2.OR.I2.EQ.J2) CALL ERREUR(101)
  257.       IF(IEL1.EQ.IMAX) GO TO 150
  258.       IEL1=IEL1+1
  259.       I1=IPT1.NUM(1,IEL1)
  260.       I2=IPT1.NUM(NBNN,IEL1)
  261.       GO TO 105
  262.   800 CONTINUE
  263. C ON EST DANS LE CAS FACILE OU ON RELIE IPT1 AVEC UN SEUL POINT
  264.       DO 801 I=1,NBELE1
  265.       IPT3.NUM(1,I)=IPT1.NUM(1,I)
  266.       IPT3.NUM(2,I)=IPT1.NUM(NBNN,I)
  267.       IPT3.NUM(3,I)=IPO2
  268.  801  CONTINUE
  269.   150 CONTINUE
  270. C  OK C'EST FAIT  EVENTUELLEMENT CONVERTIR LE TYPE D'ELEMENT
  271.       IF (NBNN.EQ.2) ITY=4
  272.       IF (NBNN.EQ.3) ITY=6
  273.       CALL CHANGE(IPT3,ITY)
  274.       IF (IERR.NE.0) RETURN
  275.       SEGACT IPT3*MOD
  276.       DO 14 I=1,IPT3.NUM(/2)
  277.          IPT3.ICOLOR(I)=ICHCOL
  278.  14   CONTINUE
  279.  
  280.  999  CONTINUE
  281.       CALL ACTOBJ('MAILLAGE',IPT3,1)
  282.       CALL ECROBJ('MAILLAGE',IPT3)
  283.       SEGDES,MCOORD
  284.       RETURN
  285.       END
  286.  
  287.  
  288.  

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