Télécharger la plaquette Cast3M


fr en

Télécharger genjo3.eso

Retour à la liste

Numérotation des lignes : 

genjo3

  1. C GENJO3    SOURCE    BP208322  16/11/18    21:17:21     9177           
  2.       SUBROUTINE GENJO3
  3. C--------------------------------------------------------------------
  4. C
  5. C     MAIL1 = GENJ MAIL2 FLOT1;
  6. C
  7. C     MAIL1 : MAILLAGE DE JOT3 OU JOI4
  8. C     MAIL2 : MAILLAGE DE CUB8, PRI6, PYR5 ET/OU TET4
  9. C     FLOT1 : TOLERANCE
  10. C
  11. C     Pierre Pegon/JRC Ispra
  12. C--------------------------------------------------------------------
  13.       IMPLICIT INTEGER(I-N)
  14.       IMPLICIT REAL*8 (A-H,O-Z)
  15. C
  16.  
  17. -INC PPARAM
  18. -INC CCOPTIO
  19. -INC SMELEME
  20. -INC SMCOORD
  21. -INC CCGEOME
  22. -INC SMLENTI
  23. -INC SMLREEL
  24. C
  25.       SEGMENT,JO4GEN
  26.         INTEGER P4(4,NCOT4)
  27.         INTEGER SZ4(NCOT4), NELM4(NCOT4)
  28.         INTEGER FLA4(NCOT4)
  29.       ENDSEGMENT
  30.       POINTEUR JO4GE1.JO4GEN
  31. C
  32.       SEGMENT,JO3GEN
  33.         INTEGER P3(3,NCOT3)
  34.         INTEGER SZ3(NCOT3), NELM3(NCOT3)
  35.         INTEGER FLA3(NCOT3)
  36.       ENDSEGMENT
  37.       POINTEUR JO3GE1.JO3GEN
  38. C
  39.       LOGICAL GENTST
  40.       DIMENSION FAC1(3,4),FAC2(3,4),BAR1(3),BAR2(3)
  41. C
  42.       IF(IIMPI.EQ.1790)THEN
  43.         WRITE(IOIMP,*)'GENJO3: On entre dans la subroutine'
  44.       ENDIF
  45. C
  46.       CALL LIROBJ('MAILLAGE',IPT1,1,IRET)
  47.       IF(IERR.NE.0) RETURN
  48.       CALL LIRREE(XTOL,1,IRET)
  49.       IF(IERR.NE.0) RETURN
  50.       XTOL2=XTOL**2
  51. C
  52. C     VERIFICATION DE LA DIMENSION
  53. C
  54.       IF (IDIM.NE.3)THEN
  55.         WRITE(IOIMP,*)'GENJO3: on n"est pas en 3D'
  56.         RETURN
  57.       ENDIF
  58. C
  59. C     VERIFICATION DES TYPES D'ELEMENT (POUR LE MOMENT CUB8, PRI6,
  60. C                                                      PYR5 ET TET4)
  61. C     ET CALCUL DU NOMBRE DE COTES
  62. C
  63.       NCOT4=0
  64.       NCOT3=0
  65.       SEGACT,IPT1
  66.       NBSOUS=IPT1.LISOUS(/1)
  67.       DO IE1=1,MAX(NBSOUS,1)
  68.         IF(NBSOUS.EQ.0)THEN
  69.           MELEME=IPT1
  70.         ELSE
  71.           MELEME=IPT1.LISOUS(IE1)
  72.           SEGACT,MELEME
  73.         ENDIF
  74.         ILC=ITYPEL
  75.         IF(ILC.NE.14.AND.ILC.NE.16.AND.ILC.NE.23.AND.ILC.NE.25)THEN
  76.           WRITE(IOIMP,*)'GENJO3: type d"element incorrect'
  77.           SEGDES,MELEME*NOMOD
  78.           RETURN
  79.         ELSE
  80.           NBELEM=ICOLOR(/1)
  81.           IF(ILC.EQ.23)THEN
  82.             NCOT3=NCOT3+4*NBELEM
  83.           ELSEIF(ILC.EQ.14)THEN
  84.             NCOT4=NCOT4+6*NBELEM
  85.           ELSEIF(ILC.EQ.16)THEN
  86.             NCOT3=NCOT3+2*NBELEM
  87.             NCOT4=NCOT4+3*NBELEM
  88.           ELSEIF(ILC.EQ.25)THEN
  89.             NCOT3=NCOT3+4*NBELEM
  90.             NCOT4=NCOT4+  NBELEM
  91.           ENDIF
  92.         ENDIF
  93.         SEGDES,MELEME*NOMOD
  94.       ENDDO
  95. C
  96.       IF(IIMPI.EQ.1790)THEN
  97.         WRITE(IOIMP,*)'GENJO3: fin verification'
  98.       ENDIF
  99. C
  100. C     REMPLISSAGE DU SEGMENT DES COTES
  101. C
  102.       SEGACT,IPT1
  103.       SEGINI,JO3GEN,JO4GEN
  104.       IJOI3=0
  105.       IJOI4=0
  106.       DO IE1=1,MAX(NBSOUS,1)
  107.         IF(NBSOUS.EQ.0)THEN
  108.           MELEME=IPT1
  109.         ELSE
  110.           MELEME=IPT1.LISOUS(IE1)
  111.           SEGACT,MELEME
  112.         ENDIF
  113.         ILC=ITYPEL
  114.         NBELEM=ICOLOR(/1)
  115.         DO IE2=1,NBELEM
  116.           IF(ILC.EQ.23)THEN
  117.             CALL GF2323(P3,SZ3,NELM3,FLA3, IJOI3,3,
  118.      >                  NUM(1,IE2),MIN(NBSOUS,IE1),IE2)
  119.           ELSEIF(ILC.EQ.14)THEN
  120.             CALL GF1424(P4,SZ4,NELM4,FLA4, IJOI4,4,
  121.      >                  NUM(1,IE2),MIN(NBSOUS,IE1),IE2)
  122.           ELSEIF(ILC.EQ.16)THEN
  123.             CALL GF1623(P3,SZ3,NELM3,FLA3, IJOI3,3,
  124.      >                  NUM(1,IE2),MIN(NBSOUS,IE1),IE2)
  125.             CALL GF1624(P4,SZ4,NELM4,FLA4, IJOI4,4,
  126.      >                  NUM(1,IE2),MIN(NBSOUS,IE1),IE2)
  127.           ELSEIF(ILC.EQ.25)THEN
  128.             CALL GF2523(P3,SZ3,NELM3,FLA3, IJOI3,3,
  129.      >                  NUM(1,IE2),MIN(NBSOUS,IE1),IE2)
  130.             CALL GF2524(P4,SZ4,NELM4,FLA4, IJOI4,4,
  131.      >                  NUM(1,IE2),MIN(NBSOUS,IE1),IE2)
  132.           ENDIF
  133.         ENDDO
  134.       ENDDO
  135. C
  136.       IF(IIMPI.EQ.1790)THEN
  137.         WRITE(IOIMP,*)'GENJO3: fin remplissage'
  138.       ENDIF
  139. C
  140. C     ELIMINATION DES DOUBLONS A NOEUDS IDENTIQUES
  141. C
  142.       IF(NCOT3.GT.0)THEN
  143.         JG=NCOT3
  144.         SEGINI,MLENTI,MLENT1
  145.         DO IE1=1,NCOT3
  146.           LECT(IE1)=IE1
  147.           MLENT1.LECT(IE1)=FLA3(IE1)
  148.         ENDDO
  149.         CALL GENOR2(MLENT1.LECT,LECT,NCOT3)
  150.         IF(IIMPI.EQ.1790)THEN
  151.           WRITE(IOIMP,*)'GENJO3: fin de mise en ordre'
  152.         ENDIF
  153.         IFI=MLENT1.LECT(1)
  154.         DO IE1=2,NCOT3
  155.           IFF=MLENT1.LECT(IE1)
  156.           IF(IFI.EQ.IFF)THEN
  157.             JE1=LECT(IE1-1)
  158.             IF(FLA3(JE1).NE.0)THEN
  159.               DO IE2=IE1,NCOT3
  160.                 IFFF=MLENT1.LECT(IE2)
  161.                 IF(IFI.NE.IFFF)GOTO 30
  162.                 JE2=LECT(IE2)
  163.                 IF(FLA3(JE2).NE.0)THEN
  164.                   IF(GENTST(P3(1,JE1),P3(1,JE2),3))THEN
  165.                     FLA3(JE1)=0
  166.                     FLA3(JE2)=0
  167.                     GOTO 30
  168.                   ENDIF
  169.                 ENDIF
  170.               ENDDO
  171.             ENDIF
  172.           ENDIF
  173.  30       IFI=IFF
  174.         ENDDO
  175.         SEGSUP,MLENTI,MLENT1
  176.       ENDIF
  177. C
  178.       IF(NCOT4.GT.0)THEN
  179.         JG=NCOT4
  180.         SEGINI,MLENTI,MLENT1
  181.         DO IE1=1,NCOT4
  182.           LECT(IE1)=IE1
  183.           MLENT1.LECT(IE1)=FLA4(IE1)
  184.         ENDDO
  185.         CALL GENOR2(MLENT1.LECT,LECT,NCOT4)
  186.         IF(IIMPI.EQ.1790)THEN
  187.           WRITE(IOIMP,*)'GENJO3: fin de mise en ordre'
  188.         ENDIF
  189.         IFI=MLENT1.LECT(1)
  190.         DO IE1=2,NCOT4
  191.           IFF=MLENT1.LECT(IE1)
  192.           IF(IFI.EQ.IFF)THEN
  193.             JE1=LECT(IE1-1)
  194.             IF(FLA4(JE1).NE.0)THEN
  195.               DO IE2=IE1,NCOT4
  196.                 IFFF=MLENT1.LECT(IE2)
  197.                 IF(IFI.NE.IFFF)GOTO 40
  198.                 JE2=LECT(IE2)
  199.                 IF(FLA4(JE2).NE.0)THEN
  200.                   IF(GENTST(P4(1,JE1),P4(1,JE2),4))THEN
  201.                     FLA4(JE1)=0
  202.                     FLA4(JE2)=0
  203.                     GOTO 40
  204.                   ENDIF
  205.                 ENDIF
  206.               ENDDO
  207.             ENDIF
  208.           ENDIF
  209.  40       IFI=IFF
  210.         ENDDO
  211.         SEGSUP,MLENTI,MLENT1
  212.       ENDIF
  213. C
  214.       IF(IIMPI.EQ.1790)THEN
  215.         WRITE(IOIMP,*)'GENJO3: fin elimination des doublons'
  216.       ENDIF
  217. C
  218. C     CONCATENATION DES LISTES
  219. C
  220.       IF (NCOT3.GT.0)THEN
  221.         NNCOT3=NCOT3
  222.         NCOT3=0
  223.         DO IE1=1,NNCOT3
  224.           IF(FLA3(IE1).NE.0)NCOT3=NCOT3+1
  225.         ENDDO
  226.         SEGINI,JO3GE1
  227.         JE1=0
  228.         DO IE1=1,NNCOT3
  229.           IF(FLA3(IE1).NE.0)THEN
  230.             JE1=JE1+1
  231.             DO IE2=1,IDIM
  232.               JO3GE1.P3(IE2,JE1)=P3(IE2,IE1)
  233.             ENDDO
  234.             JO3GE1.SZ3(JE1)=SZ3(IE1)
  235.             JO3GE1.NELM3(JE1)=NELM3(IE1)
  236.             JO3GE1.FLA3(JE1)=0
  237.           ENDIF
  238.         ENDDO
  239.         SEGSUP,JO3GEN
  240.         JO3GEN=JO3GE1
  241.       ENDIF
  242. C
  243.       IF (NCOT4.GT.0)THEN
  244.         NNCOT4=NCOT4
  245.         NCOT4=0
  246.         DO IE1=1,NNCOT4
  247.           IF(FLA4(IE1).NE.0)NCOT4=NCOT4+1
  248.         ENDDO
  249.         SEGINI,JO4GE1
  250.         JE1=0
  251.         DO IE1=1,NNCOT4
  252.           IF(FLA4(IE1).NE.0)THEN
  253.             JE1=JE1+1
  254.             DO IE2=1,4
  255.               JO4GE1.P4(IE2,JE1)=P4(IE2,IE1)
  256.             ENDDO
  257.             JO4GE1.SZ4(JE1)=SZ4(IE1)
  258.             JO4GE1.NELM4(JE1)=NELM4(IE1)
  259.             JO4GE1.FLA4(JE1)=0
  260.           ENDIF
  261.         ENDDO
  262.         SEGSUP,JO4GEN
  263.         JO4GEN=JO4GE1
  264.       ENDIF
  265. C
  266.       IF(IIMPI.EQ.1790)THEN
  267.         WRITE(IOIMP,*)'GENJO3: fin concatenation'
  268.       ENDIF
  269. C
  270. C     DETERMINATION DES SEGMENTS AVEC VIS-A-VIS
  271. C
  272.       IRET=0
  273.       IF(NCOT3.GT.1)THEN
  274.         JG=NCOT3
  275.         SEGINI,MLENTI,MLREEL
  276.         DO IE1=1,NCOT3
  277.           LECT(IE1)=IE1
  278.           DO IE2=1,IDIM
  279.             BAR1(IE2)=0.D0
  280.           ENDDO
  281.           DO IE2=1,3
  282.             IPR1=(IDIM+1)*(P3(IE2,IE1)-1)
  283.             DO IE3=1,IDIM
  284.               BAR1(IE3)=BAR1(IE3)+XCOOR(IPR1+IE3)
  285.             ENDDO
  286.           ENDDO
  287.           PROG(IE1)=SQRT(BAR1(1)**2+BAR1(2)**2+BAR1(3)**2)/3
  288.         ENDDO
  289.         CALL GENOS2(PROG,LECT,NCOT3)
  290.         IF(IIMPI.EQ.1790)THEN
  291.           WRITE(IOIMP,*)'GENJO3: fin de mise en ordre'
  292.         ENDIF
  293.         XFI=PROG(1)
  294.         DO IE1=2,NCOT3
  295.           XFF=PROG(IE1)
  296.           IF(ABS(XFI-XFF).LT.XTOL)THEN
  297.             JE1=LECT(IE1-1)
  298.             IF(FLA3(JE1).EQ.0)THEN
  299.               DO IE2=1,IDIM
  300.                 BAR1(IE2)=0.D0
  301.               ENDDO
  302.               DO IE2=1,3
  303.                 IPR1=(IDIM+1)*(P3(IE2,JE1)-1)
  304.                 DO IE3=1,IDIM
  305.                   FAC1(IE3,IE2)=XCOOR(IPR1+IE3)
  306.                   BAR1(IE3)=BAR1(IE3)+FAC1(IE3,IE2)
  307.                 ENDDO
  308.               ENDDO
  309.               DO IE2=IE1,NCOT3
  310.                 XFFF=PROG(IE2)
  311.                 IF(ABS(XFI-XFFF).GE.XTOL)GOTO 31
  312.                 JE2=LECT(IE2)
  313.                 IF(FLA3(JE2).EQ.0)THEN
  314.                   DO IE3=1,IDIM
  315.                     BAR2(IE3)=0.D0
  316.                   ENDDO
  317.                   DO IE3=1,3
  318.                     IPR2=(IDIM+1)*(P3(IE3,JE2)-1)
  319.                     DO IE4=1,IDIM
  320.                       FAC2(IE4,IE3)=XCOOR(IPR2+IE4)
  321.                       BAR2(IE4)=BAR2(IE4)+FAC2(IE4,IE3)
  322.                     ENDDO
  323.                   ENDDO
  324.                   DIS12=0.D0
  325.                   DO IE3=1,IDIM
  326.                     DIS12=DIS12+(BAR2(IE3)-BAR1(IE3))**2
  327.                   ENDDO
  328.                   DIS12=DIS12/9
  329.                   IF(DIS12.LT.XTOL2)THEN
  330.                     FLA3(JE1)=JE2
  331.                     FLA3(JE2)=JE1
  332.                     CALL GENRD1(FAC1,FAC2,P3(1,JE2),3,XTOL2,IRET)
  333.                     IF(IRET.NE.0)GOTO 9999
  334.                     GOTO 31
  335.                   ENDIF
  336.                 ENDIF
  337.               ENDDO
  338.             ENDIF
  339.           ENDIF
  340.  31       XFI=XFF
  341.         ENDDO
  342.         SEGSUP,MLREEL,MLENTI
  343.       ENDIF
  344. C
  345.       IRET=0
  346.       IF(NCOT4.GT.1)THEN
  347.         JG=NCOT4
  348.         SEGINI,MLENTI,MLREEL
  349.         DO IE1=1,NCOT4
  350.           LECT(IE1)=IE1
  351.           DO IE2=1,IDIM
  352.             BAR1(IE2)=0.D0
  353.           ENDDO
  354.           DO IE2=1,4
  355.             IPR1=(IDIM+1)*(P4(IE2,IE1)-1)
  356.             DO IE3=1,IDIM
  357.               BAR1(IE3)=BAR1(IE3)+XCOOR(IPR1+IE3)
  358.             ENDDO
  359.           ENDDO
  360.           PROG(IE1)=SQRT(BAR1(1)**2+BAR1(2)**2+BAR1(3)**2)/4
  361.         ENDDO
  362.         CALL GENOS2(PROG,LECT,NCOT4)
  363.         IF(IIMPI.EQ.1790)THEN
  364.           WRITE(IOIMP,*)'GENJO3: fin de mise en ordre'
  365.         ENDIF
  366.         XFI=PROG(1)
  367.         DO IE1=2,NCOT4
  368.           XFF=PROG(IE1)
  369.           IF(ABS(XFI-XFF).LT.XTOL)THEN
  370.             JE1=LECT(IE1-1)
  371.             IF(FLA4(JE1).EQ.0)THEN
  372.               DO IE2=1,IDIM
  373.                 BAR1(IE2)=0.D0
  374.               ENDDO
  375.               DO IE2=1,4
  376.                 IPR1=(IDIM+1)*(P4(IE2,JE1)-1)
  377.                 DO IE3=1,IDIM
  378.                   FAC1(IE3,IE2)=XCOOR(IPR1+IE3)
  379.                   BAR1(IE3)=BAR1(IE3)+FAC1(IE3,IE2)
  380.                 ENDDO
  381.               ENDDO
  382.               DO IE2=IE1,NCOT4
  383.                 XFFF=PROG(IE2)
  384.                 IF(ABS(XFI-XFFF).GE.XTOL)GOTO 41
  385.                 JE2=LECT(IE2)
  386.                 IF(FLA4(JE2).EQ.0)THEN
  387.                   DO IE3=1,IDIM
  388.                     BAR2(IE3)=0.D0
  389.                   ENDDO
  390.                   DO IE3=1,4
  391.                     IPR2=(IDIM+1)*(P4(IE3,JE2)-1)
  392.                     DO IE4=1,IDIM
  393.                       FAC2(IE4,IE3)=XCOOR(IPR2+IE4)
  394.                       BAR2(IE4)=BAR2(IE4)+FAC2(IE4,IE3)
  395.                     ENDDO
  396.                   ENDDO
  397.                   DIS12=0.D0
  398.                   DO IE3=1,IDIM
  399.                     DIS12=DIS12+(BAR2(IE3)-BAR1(IE3))**2
  400.                   ENDDO
  401.                   DIS12=DIS12/16
  402.                   IF(DIS12.LT.XTOL2)THEN
  403.                     FLA4(JE1)=JE2
  404.                     FLA4(JE2)=JE1
  405.                     CALL GENRD1(FAC1,FAC2,P4(1,JE2),4,XTOL2,IRET)
  406.                     IF(IRET.NE.0)GOTO 9999
  407.                     GOTO 41
  408.                   ENDIF
  409.                 ENDIF
  410.               ENDDO
  411.             ENDIF
  412.           ENDIF
  413.  41       XFI=XFF
  414.         ENDDO
  415.         SEGSUP,MLREEL,MLENTI
  416.       ENDIF
  417. C
  418.       IF(IIMPI.EQ.1790)THEN
  419.         WRITE(IOIMP,*)'GENJO3: fin determination des vis-a-vis'
  420.       ENDIF
  421. C
  422. C     CREATION DU/DES MAILLAGE(S) DE JOINT
  423. C
  424.       NBREF=0
  425.       NBSOUS=0
  426.       NBELEM=0
  427.       DO IE1=1,NCOT3
  428.         IF(FLA3(IE1).NE.0)NBELEM=NBELEM+1
  429.       ENDDO
  430.       NBELEM=NBELEM/2
  431.       IF(NBELEM.NE.0)THEN
  432.         NBNN=6
  433.         SEGINI,MELEME
  434.         ITYPEL=18
  435.         DO IE1=1,NBELEM
  436.           ICOLOR(IE1)=0
  437.         ENDDO
  438.         IPT3=MELEME
  439.       ELSE
  440.         IPT3=0
  441.       ENDIF
  442. C
  443.       NBELEM=0
  444.       DO IE1=1,NCOT4
  445.         IF(FLA4(IE1).NE.0)NBELEM=NBELEM+1
  446.       ENDDO
  447.       NBELEM=NBELEM/2
  448.       IF(NBELEM.NE.0)THEN
  449.         NBNN=8
  450.         SEGINI,MELEME
  451.         ITYPEL=19
  452.         DO IE1=1,NBELEM
  453.           ICOLOR(IE1)=0
  454.         ENDDO
  455.         IPT4=MELEME
  456.       ELSE
  457.         IPT4=0
  458.       ENDIF
  459. C
  460.       IF(IPT3*IPT4.EQ.0)THEN
  461.         IF(IPT3.EQ.0.AND.IPT4.EQ.0)THEN
  462.           WRITE(IOIMP,*)'GENJO3: aucun joint cree'
  463.           GOTO 9999
  464.         ELSEIF(IPT3.NE.0)THEN
  465.           IPT2=IPT3
  466.         ELSE
  467.           IPT2=IPT4
  468.         ENDIF
  469.       ELSE
  470.         NBSOUS=2
  471.         NBNN=0
  472.         NBELEM=0
  473.         SEGINI,MELEME
  474.         LISOUS(1)=IPT3
  475.         LISOUS(2)=IPT4
  476.         IPT2=MELEME
  477.         SEGDES,MELEME
  478.       ENDIF
  479. C
  480.       IF(IIMPI.EQ.1790)THEN
  481.         WRITE(IOIMP,*)'GENJO3: fin creation maillage'
  482.       ENDIF
  483. C
  484. C     GENERATION DU/DES MAILLAGE(S) DE JOINT
  485. C
  486.       IF(IPT3.NE.0)THEN
  487.         IELEM=0
  488.         DO IE1=1,NCOT3
  489.           IF(FLA3(IE1).NE.0)THEN
  490.             IELEM=IELEM+1
  491. *
  492. *         premier barycentre
  493. *
  494.             DO IE2=1,IDIM
  495.               BAR1(IE2)=0.D0
  496.             ENDDO
  497.             IF(SZ3(IE1).EQ.0)THEN
  498.               MELEME=IPT1
  499.             ELSE
  500.               MELEME=IPT1.LISOUS(SZ3(IE1))
  501.             ENDIF
  502.             NBNN=NUM(/1)
  503.             DO IE3=1,NBNN
  504.               IPDUM=(IDIM+1)*(NUM(IE3,NELM3(IE1))-1)
  505.               DO IE4=1,IDIM
  506.                 BAR1(IE4)=BAR1(IE4)+XCOOR(IPDUM+IE4)
  507.               ENDDO
  508.             ENDDO
  509.             DO IE2=1,IDIM
  510.               BAR1(IE2)=BAR1(IE2)/NBNN
  511.             ENDDO
  512. *
  513. *         Chargement de la premiere face
  514. *
  515.             DO IE2=1,3
  516.               IPR1=(IDIM+1)*(P3(IE2,IE1)-1)
  517.               DO IE3=1,IDIM
  518.                 FAC1(IE3,IE2)=XCOOR(IPR1+IE3)
  519.               ENDDO
  520.             ENDDO
  521. *
  522. *         second barycentre
  523. *
  524.             JE1=FLA3(IE1)
  525.             DO IE2=1,IDIM
  526.               BAR2(IE2)=0.D0
  527.             ENDDO
  528.             IF(SZ3(JE1).EQ.0)THEN
  529.               MELEME=IPT1
  530.             ELSE
  531.               MELEME=IPT1.LISOUS(SZ3(JE1))
  532.             ENDIF
  533.             NBNN=NUM(/1)
  534.             DO IE3=1,NBNN
  535.               IPDUM=(IDIM+1)*(NUM(IE3,NELM3(JE1))-1)
  536.               DO IE4=1,IDIM
  537.                 BAR2(IE4)=BAR2(IE4)+XCOOR(IPDUM+IE4)
  538.               ENDDO
  539.             ENDDO
  540.             DO IE2=1,IDIM
  541.               BAR2(IE2)=BAR2(IE2)/NBNN
  542.             ENDDO
  543. *
  544. *         Chargement de la seconde face
  545. *
  546.             DO IE2=1,3
  547.               IPR1=(IDIM+1)*(P3(IE2,JE1)-1)
  548.               DO IE3=1,IDIM
  549.                 FAC2(IE3,IE2)=XCOOR(IPR1+IE3)
  550.               ENDDO
  551.             ENDDO
  552. *
  553. *         On ordonne correctement les points
  554. *
  555.             CALL GENRD2(FAC1,BAR1,P3(1,IE1),BAR2,P3(1,JE1),3,TOL)
  556. *
  557. *         On charge le joint
  558. *
  559.             DO IE2=1,3
  560.               IPT3.NUM(IE2  ,IELEM)=P3(IE2,IE1)
  561.               IPT3.NUM(IE2+3,IELEM)=P3(IE2,JE1)
  562.             ENDDO
  563. *
  564. *         on efface les 2 cotes
  565. *
  566.             FLA3(IE1)=0
  567.             FLA3(JE1)=0
  568.           ENDIF
  569.         ENDDO
  570.         SEGDES,IPT3
  571.       ENDIF
  572. C
  573.       IF(IPT4.NE.0)THEN
  574.         IELEM=0
  575.         DO IE1=1,NCOT4
  576.           IF(FLA4(IE1).NE.0)THEN
  577.             IELEM=IELEM+1
  578. *
  579. *         premier barycentre
  580. *
  581.             DO IE2=1,IDIM
  582.               BAR1(IE2)=0.D0
  583.             ENDDO
  584.             IF(SZ4(IE1).EQ.0)THEN
  585.               MELEME=IPT1
  586.             ELSE
  587.               MELEME=IPT1.LISOUS(SZ4(IE1))
  588.             ENDIF
  589.             NBNN=NUM(/1)
  590.             DO IE3=1,NBNN
  591.               IPDUM=(IDIM+1)*(NUM(IE3,NELM4(IE1))-1)
  592.               DO IE4=1,IDIM
  593.                 BAR1(IE4)=BAR1(IE4)+XCOOR(IPDUM+IE4)
  594.               ENDDO
  595.             ENDDO
  596.             DO IE2=1,IDIM
  597.               BAR1(IE2)=BAR1(IE2)/NBNN
  598.             ENDDO
  599. *
  600. *         Chargement de la premiere face
  601. *
  602.             DO IE2=1,4
  603.               IPR1=(IDIM+1)*(P4(IE2,IE1)-1)
  604.               DO IE3=1,IDIM
  605.                 FAC1(IE3,IE2)=XCOOR(IPR1+IE3)
  606.               ENDDO
  607.             ENDDO
  608. *
  609. *         second barycentre
  610. *
  611.             JE1=FLA4(IE1)
  612.             DO IE2=1,IDIM
  613.               BAR2(IE2)=0.D0
  614.             ENDDO
  615.             IF(SZ4(JE1).EQ.0)THEN
  616.               MELEME=IPT1
  617.             ELSE
  618.               MELEME=IPT1.LISOUS(SZ4(JE1))
  619.             ENDIF
  620.             NBNN=NUM(/1)
  621.             DO IE3=1,NBNN
  622.               IPDUM=(IDIM+1)*(NUM(IE3,NELM4(JE1))-1)
  623.               DO IE4=1,IDIM
  624.                 BAR2(IE4)=BAR2(IE4)+XCOOR(IPDUM+IE4)
  625.               ENDDO
  626.             ENDDO
  627.             DO IE2=1,IDIM
  628.               BAR2(IE2)=BAR2(IE2)/NBNN
  629.             ENDDO
  630. *
  631. *         Chargement de la seconde face
  632. *
  633.             DO IE2=1,4
  634.               IPR1=(IDIM+1)*(P4(IE2,JE1)-1)
  635.               DO IE3=1,IDIM
  636.                 FAC2(IE3,IE2)=XCOOR(IPR1+IE3)
  637.               ENDDO
  638.             ENDDO
  639. *
  640. *         On ordonne correctement les points
  641. *
  642.             CALL GENRD2(FAC1,BAR1,P4(1,IE1),BAR2,P4(1,JE1),4,TOL)
  643. *
  644. *         On charge le joint
  645. *
  646.             DO IE2=1,4
  647.               IPT4.NUM(IE2  ,IELEM)=P4(IE2,IE1)
  648.               IPT4.NUM(IE2+4,IELEM)=P4(IE2,JE1)
  649.             ENDDO
  650. *
  651. *         on efface les 2 cotes
  652. *
  653.             FLA4(IE1)=0
  654.             FLA4(JE1)=0
  655.           ENDIF
  656.         ENDDO
  657.         SEGDES,IPT4
  658.       ENDIF
  659. C
  660.       IF(IIMPI.EQ.1790)THEN
  661.         WRITE(IOIMP,*)'GENJO3: fin chargement maillage'
  662.       ENDIF
  663. C
  664. C     DESTRUCTION, DESACTIVATION ET RETOUR A GIBIANE
  665. C
  666.       CALL ECROBJ('MAILLAGE',IPT2)
  667. C
  668.  9999 SEGSUP,JO3GEN,JO4GEN
  669. C
  670.       NBSOUS=IPT1.LISOUS(/1)
  671.       DO IE1=1,MAX(NBSOUS,1)
  672.         IF(NBSOUS.EQ.0)THEN
  673.           MELEME=IPT1
  674.         ELSE
  675.           MELEME=IPT1.LISOUS(IE1)
  676.         ENDIF
  677.         SEGDES,MELEME*NOMOD
  678.       ENDDO
  679. C
  680.       RETURN
  681.       END
  682.  
  683.  
  684.  
  685.  
  686.  
  687.  
  688.  
  689.  

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