Télécharger la plaquette Cast3M


fr en

Télécharger dedou.eso

Retour à la liste

Numérotation des lignes : 

dedou

  1. C DEDOU     SOURCE    CB215821  26/08/24    21:16:01     12622          
  2.       SUBROUTINE DEDOU
  3. C
  4.       IMPLICIT INTEGER(I-N)
  5.       IMPLICIT REAL*8 (A-H,O-Z)
  6.  
  7. -INC PPARAM
  8. -INC CCOPTIO
  9. -INC SMELEME
  10. -INC SMCOORD
  11. C
  12.       SEGMENT TTRAV
  13.          INTEGER     ILIS(NNOE)
  14.       ENDSEGMENT
  15.       SEGMENT XDET(NNOE)
  16.       SEGMENT ICPR(nbpts)
  17.       IF(IDIM.NE.2) THEN
  18.         INTERR(1)=IDIM
  19.         CALL ERREUR(709)
  20.         RETURN
  21.       ENDIF
  22. C
  23. C *** LECTURE DU MAILLAGE
  24. C
  25.       CALL LIROBJ ('MAILLAGE',IPT1,1,IRETOU)
  26.       IF(IERR.NE.0) RETURN
  27.       SEGINI,MELEME=IPT1
  28.       IF(LISOUS(/1).NE.0) THEN
  29.         DO 1 I=1,LISOUS(/1)
  30.            IPT3=LISOUS(I)
  31.            SEGINI,IPT2=IPT3
  32.            LISOUS(I)=IPT2
  33.            SEGDES IPT2
  34.  1      CONTINUE
  35.       ENDIF
  36.       NBREF=0
  37.       NBNN=NUM(/1)
  38.       NBELEM=NUM(/2)
  39.       NBSOUS=LISOUS(/1)
  40.       SEGADJ MELEME
  41.       SEGDES MELEME
  42. C
  43. C *** LECTURE DE LA LIGNE A DEDOUBLER
  44. C *** TTRAV CONTIENT LA LIGNE REORDONNEE ET ORIENTEE PAR LIGMAI
  45. C
  46.       CALL LIROBJ ('MAILLAGE',IPT2,1,IRETOU)
  47.       IF(IERR.NE.0) RETURN
  48.       CALL LIGMAI(IPT2,TTRAV,0)
  49.       IF(IERR.NE.0) THEN
  50. C     Menage avant de quitter en erreur
  51.          SEGACT MELEME*MOD
  52.          IF(LISOUS(/1).NE.0) THEN
  53.             DO 111 I=1,LISOUS(/1)
  54.             IPT3=LISOUS(I)
  55.             SEGSUP IPT3
  56.  111        CONTINUE
  57.          ENDIF
  58.          SEGSUP MELEME
  59.          RETURN
  60.       ENDIF
  61.  
  62.       SEGACT TTRAV
  63. C
  64. C *** CREATION DE LA DEUXIEME LEVRE
  65. C
  66.       SEGINI,IPT5=IPT2
  67. C
  68. C *** ON REGARDE SI LA FISSURE EST DEBOUCHANTE
  69. C
  70.       CALL ECROBJ('MAILLAGE',MELEME)
  71.       CALL PRCONT
  72.       IF(IERR.NE.0) THEN
  73. C     Menage avant de quitter en erreur
  74.          SEGACT MELEME*MOD
  75.          IF(LISOUS(/1).NE.0) THEN
  76.             DO 112 I=1,LISOUS(/1)
  77.             IPT3=LISOUS(I)
  78.             SEGSUP IPT3
  79.  112        CONTINUE
  80.          ENDIF
  81.          SEGSUP MELEME
  82.          SEGSUP IPT5
  83.          RETURN
  84.       ENDIF
  85.       SEGACT MELEME
  86.       IF(LISREF(/1).NE.0) THEN
  87.         NBREF=0
  88.         NBNN=NUM(/1)
  89.         NBELEM=NUM(/2)
  90.         NBSOUS=LISOUS(/1)
  91.         SEGADJ MELEME
  92.       ENDIF
  93.       SEGDES MELEME
  94.       CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
  95.       SEGACT IPT2
  96.       DO 4 IPASS=1,2
  97.         IF(IPASS.EQ.1) THEN
  98.           I=1
  99.         ELSE
  100.           I=ILIS(/1)
  101.         ENDIF
  102.         N1=ILIS(I)
  103.         IPT3=IPT2
  104.         DO 2 ISOU=1,MAX(1,IPT2.LISOUS(/1))
  105.           IF(IPT2.LISOUS(/1).NE.0) THEN
  106.             IPT3=LISOUS(ISOU)
  107.             SEGACT IPT3
  108.           ENDIF
  109.           DO 113 K=1,IPT3.NUM(/2)
  110.           DO 3 J=1,IPT3.NUM(/1)
  111.             IF(IPT3.NUM(J,K).EQ.N1) GO TO 21
  112.  3        CONTINUE
  113.   113     CONTINUE
  114.  2      CONTINUE
  115.         GOTO 4
  116.  21     CONTINUE
  117. C Le point N1 est une extremite qui appartient au contour
  118. C On rajoute a ILIS un autre point du contour
  119.         DO 22 J=1,IPT3.NUM(/1)
  120.           IF(IPT3.NUM(J,K).NE.N1) N2=IPT3.NUM(J,K)
  121.  22     CONTINUE
  122.         NNOE=ILIS(/1)+1
  123.         SEGADJ TTRAV
  124.         IF(I.EQ.1) THEN
  125.           DO 23 K=NNOE,2,-1
  126.             ILIS(K)=ILIS(K-1)
  127.  23       CONTINUE
  128.           ILIS(1)=N2
  129.         ELSE
  130.           ILIS(NNOE)=N2
  131.         ENDIF
  132.  4    CONTINUE
  133.       IF(IPT2.LISOUS(/1).NE.0) THEN
  134.         DO 6 I=1,IPT2.LISOUS(/1)
  135.           IPT3=LISOUS(I)
  136.           SEGSUP IPT3
  137.  6      CONTINUE
  138.       ENDIF
  139.       SEGSUP IPT2
  140. C
  141. C *** AJOUT DE NOUVEAUX POINTS A MCOORD ET CREATION
  142. C *** D'UN ICPR DES NOEUDS A DEDOUBLER
  143. C
  144.       NNOE=ILIS(/1)
  145.       NDED=NNOE-2
  146.       segact mcoord*mod
  147.       NNOEU=nbpts
  148.       SEGINI ICPR
  149.       NBPTS=NNOEU+NDED
  150.       SEGADJ MCOORD
  151.       DO 5 I=2,NNOE-1
  152.         N1=ILIS(I)
  153.         N2=I+NNOEU-1
  154.         XCOOR((N2-1)*3+1)=XCOOR((N1-1)*3+1)
  155.         XCOOR((N2-1)*3+2)=XCOOR((N1-1)*3+2)
  156.         ICPR(N1)=I
  157.  5    CONTINUE
  158.       ICPR(ILIS(1))=1
  159.       ICPR(ILIS(NNOE))=NNOE
  160. C
  161. C *** CREATION DU TABLEAU XDET QUI CONTIENT LE
  162. C *** DETERMINANT DE DEUX VECTEURS CONSECUTIFS
  163. C
  164.       SEGINI XDET
  165.       N1=ILIS(1)
  166.       N2=ILIS(2)
  167.       VX1=XCOOR((N2-1)*3+1)-XCOOR((N1-1)*3+1)
  168.       VY1=XCOOR((N2-1)*3+2)-XCOOR((N1-1)*3+2)
  169.       DO 51 I=2,NNOE-1
  170.         N3=ILIS(I+1)
  171.         VX2=XCOOR((N3-1)*3+1)-XCOOR((N2-1)*3+1)
  172.         VY2=XCOOR((N3-1)*3+2)-XCOOR((N2-1)*3+2)
  173.         XDET(I)=VX1*VY2-VX2*VY1
  174.         VX1=VX2
  175.         VY1=VY2
  176.         N1=N2
  177.         N2=N3
  178.  51   CONTINUE
  179. C
  180. C *** RENUMEROTATION DES ELEMENTS DU MAILLAGE RESULTAT
  181. C
  182.       SEGACT MELEME*MOD
  183.       IPT1=MELEME
  184.       DO 7 I=1,MAX(1,LISOUS(/1))
  185.       IF(LISOUS(/1).NE.0) THEN
  186.         IPT1=LISOUS(I)
  187.         SEGACT IPT1*MOD
  188.       ENDIF
  189.       DO 8 J=1,IPT1.NUM(/2)
  190.         DO 9 K=1,IPT1.NUM(/1)
  191.           N1=IPT1.NUM(K,J)
  192.           IN1=ICPR(N1)
  193.           IF(IN1.GT.1.AND.IN1.LT.NNOE) GOTO 10
  194.  9      CONTINUE
  195.         GOTO 8
  196. C *** L'element contient un noeud N1 sur la ligne
  197. C *** N2 est le noeud suivant (sur la ligne), N3 le noeud precedent,
  198. C *** N4 un noeud de l'element qui n'appartient pas a la ligne.
  199. C *** Si l'element est "au-dessus" on va en 13 pour renumeroter.
  200.  10     N2=ILIS(IN1+1)
  201.         N3=ILIS(IN1-1)
  202.         DO 11 K=1,IPT1.NUM(/1)
  203.           N4=IPT1.NUM(K,J)
  204.           IF(ICPR(N4).EQ.0) GO TO 12
  205.  11     CONTINUE
  206. C *** Cas particulier ou tous les noeuds de l'element
  207. C *** appartiennent a la ligne
  208.         N4=IPT1.NUM(1,J)
  209.         N5=IPT1.NUM(2,J)
  210.         N6=IPT1.NUM(3,J)
  211.         IN1=MIN(ICPR(N4),ICPR(N5),ICPR(N6))+1
  212.         IF(XDET(IN1).GE.0) GOTO 13
  213.         GOTO 8
  214. C *** Cas general
  215.  12     VX1=XCOOR((N2-1)*3+1)-XCOOR((N1-1)*3+1)
  216.         VY1=XCOOR((N2-1)*3+2)-XCOOR((N1-1)*3+2)
  217.         VX2=XCOOR((N1-1)*3+1)-XCOOR((N3-1)*3+1)
  218.         VY2=XCOOR((N1-1)*3+2)-XCOOR((N3-1)*3+2)
  219.         VX3=XCOOR((N4-1)*3+1)-XCOOR((N1-1)*3+1)
  220.         VY3=XCOOR((N4-1)*3+2)-XCOOR((N1-1)*3+2)
  221.         DET1=VX1*VY3-VY1*VX3
  222.         DET2=VX2*VY3-VY2*VX3
  223.         IF(XDET(IN1).GE.0) THEN
  224.           IF(DET1.GE.0.AND.DET2.GE.0.) GOTO 13
  225.         ELSE
  226.           IF(DET1.GT.0.OR.DET2.GT.0.) GOTO 13
  227.         ENDIF
  228.         GOTO 8
  229.  13     DO 14 K=1,IPT1.NUM(/1)
  230.           N5=IPT1.NUM(K,J)
  231.           IN5=ICPR(N5)
  232.           IF(IN5.GT.1.AND.IN5.LT.NNOE)
  233.      &      IPT1.NUM(K,J)=IN5+NNOEU-1
  234.  14     CONTINUE
  235.  8    CONTINUE
  236.  7    CONTINUE
  237.       IF(LISOUS(/1).NE.0) THEN
  238.         DO 15 I=1,LISOUS(/1)
  239.           IPT1=LISOUS(I)
  240.           SEGDES IPT1
  241.  15     CONTINUE
  242.       ENDIF
  243. C
  244. C *** RENUMEROTATION DE LA DEUXIEME LEVRE
  245. C
  246.       IPT1=IPT5
  247.       DO 16 I=1,MAX(1,IPT5.LISOUS(/1))
  248.       IF(IPT5.LISOUS(/1).NE.0) THEN
  249.         IPT1=IPT5.LISOUS(I)
  250.         SEGACT IPT1
  251.       ENDIF
  252.       DO 17 J=1,IPT1.NUM(/2)
  253.         DO 18 K=1,IPT1.NUM(/1)
  254.           N1=IPT1.NUM(K,J)
  255.           IN1=ICPR(N1)
  256.           IF(IN1.GT.1.AND.IN1.LT.NNOE) IPT1.NUM(K,J)=IN1+NNOEU-1
  257.  18      CONTINUE
  258.  17   CONTINUE
  259.  16   CONTINUE
  260.       IF(IPT5.LISOUS(/1).NE.0) THEN
  261.         DO 19 I=1,IPT5.LISOUS(/1)
  262.           IPT1=IPT5.LISOUS(I)
  263.           SEGDES IPT1
  264.  19     CONTINUE
  265.       ENDIF
  266.       SEGDES IPT5,MELEME
  267.       SEGSUP TTRAV,XDET,ICPR
  268.       CALL ECROBJ ('MAILLAGE',IPT5)
  269.       CALL ECROBJ ('MAILLAGE',MELEME)
  270.       RETURN
  271.       END
  272.  
  273.  
  274.  
  275.  
  276.  
  277.  
  278.  
  279.  
  280.  
  281.  
  282.  
  283.  
  284.  
  285.  

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