Télécharger la plaquette Cast3M


fr en

Télécharger genjo2.eso

Retour à la liste

Numérotation des lignes : 

genjo2

  1. C GENJO2    SOURCE    BP208322  16/11/18    21:17:20     9177           
  2.       SUBROUTINE GENJO2
  3. C--------------------------------------------------------------------
  4. C
  5. C     MAIL1 = GENJ MAIL2 FLOT1;
  6. C
  7. C     MAIL1 : MAILLAGE DE JOI2
  8. C     MAIL2 : MAILLAGE DE QUA4 ET/OU DE TRI3
  9. C     FLOT1 : TOLERANCE
  10. C
  11. C     Pierre Pegon/JRC Ispra
  12. C     + modif PP 8/98 pour accelerer la recherche des contours
  13. C--------------------------------------------------------------------
  14.       IMPLICIT INTEGER(I-N)
  15.       IMPLICIT REAL*8 (A-H,O-Z)
  16. C
  17.  
  18. -INC PPARAM
  19. -INC CCOPTIO
  20. -INC SMELEME
  21. -INC SMCOORD
  22. -INC CCGEOME
  23. -INC SMLENTI
  24. C
  25.       SEGMENT,JOIGEN
  26.         INTEGER P1(NCOTE),P2(NCOTE),SZONE(NCOTE),NELMT(NCOTE)
  27.         INTEGER FLAG(NCOTE)
  28.       ENDSEGMENT
  29.       POINTEUR JOIGE1.JOIGEN
  30. C
  31.       CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  32.       IF(IERR.NE.0) RETURN
  33.       CALL LIRREE(XTOL,1,IRETOU)
  34.       IF(IERR.NE.0) RETURN
  35. C
  36. C     VERIFICATION DE LA DIMENSION
  37. C
  38.       IF (IDIM.NE.2)THEN
  39.         WRITE(IOIMP,*)'GENJO2: on n"est pas en 2D'
  40.         RETURN
  41.       ENDIF
  42. C
  43. C     VERIFICATION DES TYPES D'ELEMENT (POUR LE MOMENT QUA4 ET TRI3)
  44. C     ET CALCUL DU NOMBRE DE COTES
  45. C
  46.       NCOTE=0
  47.       SEGACT,IPT1
  48.       NBSOUS=IPT1.LISOUS(/1)
  49.       DO IE1=1,MAX(NBSOUS,1)
  50.         IF(NBSOUS.EQ.0)THEN
  51.           MELEME=IPT1
  52.         ELSE
  53.           MELEME=IPT1.LISOUS(IE1)
  54.           SEGACT,MELEME
  55.         ENDIF
  56.         ILC=ITYPEL
  57.         IF(ILC.NE.4.AND.ILC.NE.8)THEN
  58.           WRITE(IOIMP,*)'GENJO2: type d"element incorrect'
  59.           SEGDES,MELEME*NOMOD
  60.           RETURN
  61.         ELSE
  62.           NCOTE=NCOTE+((ILC/4)+2)*ICOLOR(/1)
  63.         ENDIF
  64.         SEGDES,MELEME*NOMOD
  65.       ENDDO
  66. C
  67. C     REMPLISSAGE DU SEGMENT DES COTES
  68. C
  69.       SEGACT,IPT1
  70.       SEGINI,JOIGEN
  71.       IJOI=0
  72.       DO IE1=1,MAX(NBSOUS,1)
  73.         IF(NBSOUS.EQ.0)THEN
  74.           MELEME=IPT1
  75.         ELSE
  76.           MELEME=IPT1.LISOUS(IE1)
  77.           SEGACT,MELEME
  78.         ENDIF
  79.         NC=(ITYPEL/4)+2
  80.         NBEL=ICOLOR(/1)
  81.         DO IE2=1,NBEL
  82.           DO IE3=1,NC
  83.             IJOI=IJOI+1
  84.             P1(IJOI)   =NUM(IE3,IE2)
  85.             P2(IJOI)   =NUM(MOD(IE3,NC)+1,IE2)
  86.             SZONE(IJOI)=MIN(NBSOUS,IE1)
  87.             NELMT(IJOI)=IE2
  88.             FLAG(IJOI) =P1(IJOI)+P2(IJOI)
  89.           ENDDO
  90.         ENDDO
  91.       ENDDO
  92. C
  93. C     ELIMINATION DES DOUBLONS A NOEUDS IDENTIQUES
  94. C
  95. C     NOUVELLE STRATEGIE AVEC TRI PREALABLE COMME DANS GENJO3 (8/98)
  96. C
  97.       JG=NCOTE
  98.       SEGINI,MLENTI,MLENT1
  99.       DO IE1=1,NCOTE
  100.         LECT(IE1)=IE1
  101.         MLENT1.LECT(IE1)=FLAG(IE1)
  102.       ENDDO
  103.       CALL GENOR2(MLENT1.LECT,LECT,NCOTE)
  104.       IFI=MLENT1.LECT(1)
  105.       DO IE1=2,NCOTE
  106.         IFF=MLENT1.LECT(IE1)
  107.         IF(IFI.EQ.IFF)THEN
  108.           JE1=LECT(IE1-1)
  109.           IF(FLAG(JE1).NE.0)THEN
  110.             DO IE2=IE1,NCOTE
  111.               IFFF=MLENT1.LECT(IE2)
  112.               IF(IFI.NE.IFFF)GOTO 10
  113.               JE2=LECT(IE2)
  114.               IF(FLAG(JE2).NE.0)THEN
  115.                 IF((P1(JE1).EQ.P1(JE2).AND.P2(JE1).EQ.P2(JE2)).OR.
  116.      >             (P1(JE1).EQ.P2(JE2).AND.P2(JE1).EQ.P1(JE2)))THEN
  117.                   FLAG(JE1)=0
  118.                   FLAG(JE2)=0
  119.                   GOTO 10
  120.                 ENDIF
  121.               ENDIF
  122.             ENDDO
  123.           ENDIF
  124.         ENDIF
  125.  10     IFI=IFF
  126.       ENDDO
  127.       SEGSUP,MLENTI,MLENT1
  128. C
  129. C     CONCATENATION DE LA LISTE
  130. C
  131.       NNCOTE=NCOTE
  132.       NCOTE=0
  133.       DO IE1=1,NNCOTE
  134.         IF(FLAG(IE1).NE.0)NCOTE=NCOTE+1
  135.       ENDDO
  136.       SEGINI,JOIGE1
  137.       IE2=0
  138.       DO IE1=1,NNCOTE
  139.         IF(FLAG(IE1).NE.0)THEN
  140.           IE2=IE2+1
  141.           JOIGE1.P1(IE2)=P1(IE1)
  142.           JOIGE1.P2(IE2)=P2(IE1)
  143.           JOIGE1.SZONE(IE2)=SZONE(IE1)
  144.           JOIGE1.NELMT(IE2)=NELMT(IE1)
  145.           JOIGE1.FLAG(IE2)=0
  146.         ENDIF
  147.       ENDDO
  148.       SEGSUP,JOIGEN
  149.       JOIGEN=JOIGE1
  150. C
  151. C     DETERMINATION DES SEGMENTS AVEC VIS-A-VIS
  152. C
  153.       DO IE1=1,NCOTE-1
  154.         IF(FLAG(IE1).EQ.0)THEN
  155.           IPR1 = (IDIM+1)*(P1(IE1)-1)
  156.           XP1  = XCOOR(IPR1+1)
  157.           YP1  = XCOOR(IPR1+2)
  158.           IPR2 = (IDIM+1)*(P2(IE1)-1)
  159.           XP2  = XCOOR(IPR2+1)
  160.           YP2  = XCOOR(IPR2+2)
  161.           DO IE2=IE1+1,NCOTE
  162.             IF(FLAG(IE2).EQ.0)THEN
  163.               IPPR1= (IDIM+1)*(P1(IE2)-1)
  164.               XPP1 = XCOOR(IPPR1+1)
  165.               YPP1 = XCOOR(IPPR1+2)
  166.               IPPR2= (IDIM+1)*(P2(IE2)-1)
  167.               XPP2 = XCOOR(IPPR2+1)
  168.               YPP2 = XCOOR(IPPR2+2)
  169.               DIST1=SQRT((XP1-XPP1)**2+(YP1-YPP1)**2)
  170.      >             +SQRT((XP2-XPP2)**2+(YP2-YPP2)**2)
  171.               DIST2=SQRT((XP1-XPP2)**2+(YP1-YPP2)**2)
  172.      >             +SQRT((XP2-XPP1)**2+(YP2-YPP1)**2)
  173. C PP 2001     IF(DIST1.LT.XTOL.OR.DIST2.LT.XTOL)THEN
  174.               IF(DIST1.LT.2*XTOL.OR.DIST2.LT.2*XTOL)THEN
  175.                 FLAG(IE1)=IE2
  176.                 FLAG(IE2)=IE1
  177. C PP 2001       IF(DIST2.LT.XTOL)THEN
  178.                 IF(DIST2.LT.2*XTOL)THEN
  179.                   IPDUM=P1(IE2)
  180.                   P1(IE2)=P2(IE2)
  181.                   P2(IE2)=IPDUM
  182.                 ENDIF
  183.                 GOTO 20
  184.               ENDIF
  185.             ENDIF
  186.           ENDDO
  187.         ENDIF
  188.  20     CONTINUE
  189.       ENDDO
  190. C
  191. C     CREATION DU MAILLAGE DE JOINT
  192. C
  193.       NBNN=4
  194.       NBREF=0
  195.       NBSOUS=0
  196.       NBELEM=0
  197.       DO IE1=1,NCOTE
  198.         IF(FLAG(IE1).NE.0)NBELEM=NBELEM+1
  199.       ENDDO
  200.       NBELEM=NBELEM/2
  201.       SEGINI,IPT2
  202.       IPT2.ITYPEL=12
  203.       DO IE1=1,NBELEM
  204.         IPT2.ICOLOR(IE1)=0
  205.       ENDDO
  206. C
  207. C     GENERATION DU MAILLAGE DE JOINT
  208. C
  209.       IELEM=0
  210.       DO IE1=1,NCOTE
  211.         IF(FLAG(IE1).NE.0)THEN
  212.           IELEM=IELEM+1
  213. *
  214. *         premier barycentre
  215. *
  216.           XG=0.D0
  217.           YG=0.D0
  218.           IF(SZONE(IE1).EQ.0)THEN
  219.             MELEME=IPT1
  220.           ELSE
  221.             MELEME=IPT1.LISOUS(SZONE(IE1))
  222.           ENDIF
  223.           DO IE3=1,NUM(/1)
  224.             IPDUM=(IDIM+1)*(NUM(IE3,NELMT(IE1))-1)
  225.             XG=XG+XCOOR(IPDUM+1)
  226.             YG=YG+XCOOR(IPDUM+2)
  227.           ENDDO
  228.           XG=XG/NUM(/1)
  229.           YG=YG/NUM(/1)
  230. *
  231. *         2 points le long du joint
  232. *
  233.           IPR1 = (IDIM+1)*(P1(IE1)-1)
  234.           XP1  = XCOOR(IPR1+1)
  235.           YP1  = XCOOR(IPR1+2)
  236.           IPR2 = (IDIM+1)*(P2(IE1)-1)
  237.           XP2  = XCOOR(IPR2+1)
  238.           YP2  = XCOOR(IPR2+2)
  239. *
  240. *         second barycentre
  241. *
  242.           IE2=FLAG(IE1)
  243.           XGG=0.D0
  244.           YGG=0.D0
  245.           IF(SZONE(IE2).EQ.0)THEN
  246.             MELEME=IPT1
  247.           ELSE
  248.             MELEME=IPT1.LISOUS(SZONE(IE2))
  249.           ENDIF
  250.           DO IE3=1,NUM(/1)
  251.             IPDUM=(IDIM+1)*(NUM(IE3,NELMT(IE2))-1)
  252.             XGG=XGG+XCOOR(IPDUM+1)
  253.             YGG=YGG+XCOOR(IPDUM+2)
  254.           ENDDO
  255.           XGG=XGG/NUM(/1)
  256.           YGG=YGG/NUM(/1)
  257. *
  258. *         produit vectoriel, et selon son signe...
  259. *
  260.           XVECT=(XP2-XP1)*(YGG-YG)-(YP2-YP1)*(XGG-XG)
  261. * PPj     IF(XVECT.GT.0)THEN
  262.           IF(XVECT.LT.0)THEN
  263.             IPT2.NUM(1,IELEM)=P1(IE1)
  264.             IPT2.NUM(2,IELEM)=P2(IE1)
  265.             IPT2.NUM(3,IELEM)=P2(IE2)
  266.             IPT2.NUM(4,IELEM)=P1(IE2)
  267.           ELSE
  268.             IPT2.NUM(1,IELEM)=P2(IE1)
  269.             IPT2.NUM(2,IELEM)=P1(IE1)
  270.             IPT2.NUM(3,IELEM)=P1(IE2)
  271.             IPT2.NUM(4,IELEM)=P2(IE2)
  272.           ENDIF
  273. *
  274. *         on efface les 2 cotes
  275. *
  276.           FLAG(IE1)=0
  277.           FLAG(IE2)=0
  278.         ENDIF
  279.       ENDDO
  280. C
  281. C     DESTRUCTION, DESACTIVATION ET RETOUR A GIBIANE
  282. C
  283.       SEGSUP,JOIGEN
  284.       NBSOUS=IPT1.LISOUS(/1)
  285.       DO IE1=1,MAX(NBSOUS,1)
  286.         IF(NBSOUS.EQ.0)THEN
  287.           MELEME=IPT1
  288.         ELSE
  289.           MELEME=IPT1.LISOUS(IE1)
  290.         ENDIF
  291.         SEGDES,MELEME*NOMOD
  292.       ENDDO
  293.       SEGDES,IPT2
  294.       CALL ECROBJ('MAILLAGE',IPT2)
  295. C
  296.       RETURN
  297.       END
  298.  
  299.  
  300.  
  301.  
  302.  
  303.  
  304.  
  305.  
  306.  

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