Télécharger la plaquette Cast3M


fr en

Télécharger j3coak.eso

Retour à la liste

Numérotation des lignes : 

j3coak

  1. C J3COAK    SOURCE    CHAT      05/01/13    00:45:59     5004
  2.       SUBROUTINE J3COAK(WWORK1,VWORK,TOL,IRET)
  3. C----------------------------------------------------
  4. C     COALESCENCE DES TROUS A ET B (ramasse miette pour les trou)
  5. C
  6. C     CODE IST(1,I): 0 point non traite
  7. C                    1 est sur le segment IST(2,I)
  8. C                    2 est sur les segments IST(2,I) et IST(3,I)
  9. C                   -1 est a l'interieur
  10. C                   -2 est a l'exterieur
  11. C
  12. C     CODE CRO(J,I): 1 cote sur le segment
  13. C                   -1 cote interieur
  14. C                   -2 cote exterieur
  15. C
  16. C     PP 6/97 12/98
  17. C     Pierre Pegon/JRC Ispra
  18. C----------------------------------------------------
  19.       IMPLICIT INTEGER(I-N)
  20.       IMPLICIT REAL*8(A-H,O-Z)
  21. -INC PPARAM
  22. -INC CCOPTIO
  23. C
  24.       SEGMENT WORK
  25.         REAL*8 XYC(2,NPTO)
  26.         INTEGER IST(3,NPTO)
  27.         REAL*8 DENS(NPTO)
  28.         INTEGER JUN
  29.       ENDSEGMENT
  30.       POINTEUR WORK1.WORK,WORK2.WORK
  31. C
  32.       SEGMENT WWORK
  33.         REAL*8 PORIG(3),VNORM(3),VI(3),VJ(3)
  34.         INTEGER FWORK
  35.         INTEGER TWORK(NTROU)
  36.       ENDSEGMENT
  37.       POINTEUR WWORK1.WWORK
  38. C
  39.       SEGMENT VWORK
  40.         INTEGER FWWORK(NFACE)
  41.       ENDSEGMENT
  42. C
  43.       LOGICAL LAINB,LAOUB,LAONB,LBINA,LBOUA,LBONA
  44. C
  45.       NTROU1=WWORK1.TWORK(/1)
  46.       NFACE=FWWORK(/1)
  47. C
  48. C     ON BOUCLE SUR LES NOUVELLES FACES ET ON EN EXTRAIT WORK QUE L'ON
  49. C     PLACE EN A (WORK1)
  50. C
  51.       NFACE=FWWORK(/1)
  52.       DO IE1=1,NFACE
  53.         IFACE=NFACE-IE1+1
  54.         WWORK=FWWORK(IFACE)
  55.         NTROU=TWORK(/1)
  56.         IF(NTROU.NE.0)THEN
  57.           IRET=IRET+1
  58.           WRITE(IOIMP,*)'J3COAK: LE NOMBRE DE TROUS DANS LES NOUVELLES'
  59.           WRITE(IOIMP,*)'        FACES DOIT ETRE NUL'
  60.           RETURN
  61.         ENDIF
  62.         WORK1=FWORK
  63. C
  64. C     ON BOUCLE SUR LES TROUS DE A QUE L"ON PLACE EN B (WORK2)
  65. C
  66.         DO IE2=1,NTROU1
  67.           WORK2=WWORK1.TWORK(IE2)
  68. C
  69. C     SI LE TROU EST ENCORE ACTIF ON REGARDE S'IL EST STRICTEMENT CONTENU
  70. C     DANS A (en 98 on adoucit au cas sur les bord!!!)
  71. C
  72.           IF(WORK2.NE.0)THEN
  73. CPP???
  74.             CALL J3COTO(WORK2,WORK1,TOL,IRET)
  75. CPP???
  76.             CALL J3COTO(WORK1,WORK2,TOL,IRET)
  77.             IF(IRET.NE.0)RETURN
  78.             NPTO1=WORK1.XYC(/2)
  79.             CALL J3TES1(WORK1.IST,NPTO1,LAINB,LAOUB,LAONB,NAONB)
  80.             NPTO2=WORK2.XYC(/2)
  81.             CALL J3TES1(WORK2.IST,NPTO2,LBINA,LBOUA,LBONA,NBONA)
  82. C pp98        IF(LBINA)THEN
  83.               IF(.NOT.LBOUA)THEN
  84. C pp98        IF(LBONA)THEN
  85. C pp98          IRET=IRET+1
  86. C pp98          WRITE(IOIMP,*)'J3COAK: A NE PEUT PAS ETRE SUR B'
  87. C pp98          RETURN
  88. C
  89. C     SI OUI, ON BOUGE LE TROU DANS LA NOUVELLE FACE
  90. C
  91. C pp98        ELSE
  92.                 NTROU=NTROU+1
  93.                 SEGADJ,WWORK
  94.                 TWORK(NTROU)=WORK2
  95.                 WWORK1.TWORK(IE2)=0
  96. C pp98        ENDIF
  97.             ENDIF
  98.           ENDIF
  99.         ENDDO
  100.       ENDDO
  101. C
  102.       RETURN
  103.       END
  104.  
  105.  
  106.  

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