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    PV        20/04/01    21:15:23     10569          
  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 3 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.  2      CONTINUE
  114.         GOTO 4
  115.  21     CONTINUE
  116. C Le point N1 est une extremite qui appartient au contour
  117. C On rajoute a ILIS un autre point du contour
  118.         DO 22 J=1,IPT3.NUM(/1)
  119.           IF(IPT3.NUM(J,K).NE.N1) N2=IPT3.NUM(J,K)
  120.  22     CONTINUE
  121.         NNOE=ILIS(/1)+1
  122.         SEGADJ TTRAV
  123.         IF(I.EQ.1) THEN
  124.           DO 23 K=NNOE,2,-1
  125.             ILIS(K)=ILIS(K-1)
  126.  23       CONTINUE
  127.           ILIS(1)=N2
  128.         ELSE
  129.           ILIS(NNOE)=N2
  130.         ENDIF
  131.  4    CONTINUE
  132.       IF(IPT2.LISOUS(/1).NE.0) THEN
  133.         DO 6 I=1,IPT2.LISOUS(/1)
  134.           IPT3=LISOUS(I)
  135.           SEGSUP IPT3
  136.  6      CONTINUE
  137.       ENDIF
  138.       SEGSUP IPT2
  139. C
  140. C *** AJOUT DE NOUVEAUX POINTS A MCOORD ET CREATION
  141. C *** D'UN ICPR DES NOEUDS A DEDOUBLER
  142. C
  143.       NNOE=ILIS(/1)
  144.       NDED=NNOE-2
  145.       segact mcoord*mod
  146.       NNOEU=nbpts
  147.       SEGINI ICPR
  148.       NBPTS=NNOEU+NDED
  149.       SEGADJ MCOORD
  150.       DO 5 I=2,NNOE-1
  151.         N1=ILIS(I)
  152.         N2=I+NNOEU-1
  153.         XCOOR((N2-1)*3+1)=XCOOR((N1-1)*3+1)
  154.         XCOOR((N2-1)*3+2)=XCOOR((N1-1)*3+2)
  155.         ICPR(N1)=I
  156.  5    CONTINUE
  157.       ICPR(ILIS(1))=1
  158.       ICPR(ILIS(NNOE))=NNOE
  159. C
  160. C *** CREATION DU TABLEAU XDET QUI CONTIENT LE
  161. C *** DETERMINANT DE DEUX VECTEURS CONSECUTIFS
  162. C
  163.       SEGINI XDET
  164.       N1=ILIS(1)
  165.       N2=ILIS(2)
  166.       VX1=XCOOR((N2-1)*3+1)-XCOOR((N1-1)*3+1)
  167.       VY1=XCOOR((N2-1)*3+2)-XCOOR((N1-1)*3+2)
  168.       DO 51 I=2,NNOE-1
  169.         N3=ILIS(I+1)
  170.         VX2=XCOOR((N3-1)*3+1)-XCOOR((N2-1)*3+1)
  171.         VY2=XCOOR((N3-1)*3+2)-XCOOR((N2-1)*3+2)
  172.         XDET(I)=VX1*VY2-VX2*VY1
  173.         VX1=VX2
  174.         VY1=VY2
  175.         N1=N2
  176.         N2=N3
  177.  51   CONTINUE
  178. C
  179. C *** RENUMEROTATION DES ELEMENTS DU MAILLAGE RESULTAT
  180. C
  181.       SEGACT MELEME*MOD
  182.       IPT1=MELEME
  183.       DO 7 I=1,MAX(1,LISOUS(/1))
  184.       IF(LISOUS(/1).NE.0) THEN
  185.         IPT1=LISOUS(I)
  186.         SEGACT IPT1*MOD
  187.       ENDIF
  188.       DO 8 J=1,IPT1.NUM(/2)
  189.         DO 9 K=1,IPT1.NUM(/1)
  190.           N1=IPT1.NUM(K,J)
  191.           IN1=ICPR(N1)
  192.           IF(IN1.GT.1.AND.IN1.LT.NNOE) GOTO 10
  193.  9      CONTINUE
  194.         GOTO 8
  195. C *** L'element contient un noeud N1 sur la ligne
  196. C *** N2 est le noeud suivant (sur la ligne), N3 le noeud precedent,
  197. C *** N4 un noeud de l'element qui n'appartient pas a la ligne.
  198. C *** Si l'element est "au-dessus" on va en 13 pour renumeroter.
  199.  10     N2=ILIS(IN1+1)
  200.         N3=ILIS(IN1-1)
  201.         DO 11 K=1,IPT1.NUM(/1)
  202.           N4=IPT1.NUM(K,J)
  203.           IF(ICPR(N4).EQ.0) GO TO 12
  204.  11     CONTINUE
  205. C *** Cas particulier ou tous les noeuds de l'element
  206. C *** appartiennent a la ligne
  207.         N4=IPT1.NUM(1,J)
  208.         N5=IPT1.NUM(2,J)
  209.         N6=IPT1.NUM(3,J)
  210.         IN1=MIN(ICPR(N4),ICPR(N5),ICPR(N6))+1
  211.         IF(XDET(IN1).GE.0) GOTO 13
  212.         GOTO 8
  213. C *** Cas general
  214.  12     VX1=XCOOR((N2-1)*3+1)-XCOOR((N1-1)*3+1)
  215.         VY1=XCOOR((N2-1)*3+2)-XCOOR((N1-1)*3+2)
  216.         VX2=XCOOR((N1-1)*3+1)-XCOOR((N3-1)*3+1)
  217.         VY2=XCOOR((N1-1)*3+2)-XCOOR((N3-1)*3+2)
  218.         VX3=XCOOR((N4-1)*3+1)-XCOOR((N1-1)*3+1)
  219.         VY3=XCOOR((N4-1)*3+2)-XCOOR((N1-1)*3+2)
  220.         DET1=VX1*VY3-VY1*VX3
  221.         DET2=VX2*VY3-VY2*VX3
  222.         IF(XDET(IN1).GE.0) THEN
  223.           IF(DET1.GE.0.AND.DET2.GE.0.) GOTO 13
  224.         ELSE
  225.           IF(DET1.GT.0.OR.DET2.GT.0.) GOTO 13
  226.         ENDIF
  227.         GOTO 8
  228.  13     DO 14 K=1,IPT1.NUM(/1)
  229.           N5=IPT1.NUM(K,J)
  230.           IN5=ICPR(N5)
  231.           IF(IN5.GT.1.AND.IN5.LT.NNOE)
  232.      &      IPT1.NUM(K,J)=IN5+NNOEU-1
  233.  14     CONTINUE
  234.  8    CONTINUE
  235.  7    CONTINUE
  236.       IF(LISOUS(/1).NE.0) THEN
  237.         DO 15 I=1,LISOUS(/1)
  238.           IPT1=LISOUS(I)
  239.           SEGDES IPT1
  240.  15     CONTINUE
  241.       ENDIF
  242. C
  243. C *** RENUMEROTATION DE LA DEUXIEME LEVRE
  244. C
  245.       IPT1=IPT5
  246.       DO 16 I=1,MAX(1,IPT5.LISOUS(/1))
  247.       IF(IPT5.LISOUS(/1).NE.0) THEN
  248.         IPT1=IPT5.LISOUS(I)
  249.         SEGACT IPT1
  250.       ENDIF
  251.       DO 17 J=1,IPT1.NUM(/2)
  252.         DO 18 K=1,IPT1.NUM(/1)
  253.           N1=IPT1.NUM(K,J)
  254.           IN1=ICPR(N1)
  255.           IF(IN1.GT.1.AND.IN1.LT.NNOE) IPT1.NUM(K,J)=IN1+NNOEU-1
  256.  18      CONTINUE
  257.  17   CONTINUE
  258.  16   CONTINUE
  259.       IF(IPT5.LISOUS(/1).NE.0) THEN
  260.         DO 19 I=1,IPT5.LISOUS(/1)
  261.           IPT1=IPT5.LISOUS(I)
  262.           SEGDES IPT1
  263.  19     CONTINUE
  264.       ENDIF
  265.       SEGDES IPT5,MELEME
  266.       SEGSUP TTRAV,XDET,ICPR
  267.       CALL ECROBJ ('MAILLAGE',IPT5)
  268.       CALL ECROBJ ('MAILLAGE',MELEME)
  269.       RETURN
  270.       END
  271.  
  272.  
  273.  
  274.  
  275.  
  276.  
  277.  
  278.  
  279.  
  280.  
  281.  
  282.  
  283.  

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