Esope source files

   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  CCOPTIO

  22 : C
  23 :       SEGMENT WORK
  24 :         REAL*8 XYC(2,NPTO)
  25 :         INTEGER IST(3,NPTO)
  26 :         REAL*8 DENS(NPTO)
  27 :         INTEGER JUN
  28 :       ENDSEGMENT
  29 :       POINTEUR WORK1.WORK,WORK2.WORK
  30 : C
  31 :       SEGMENT WWORK
  32 :         REAL*8 PORIG(3),VNORM(3),VI(3),VJ(3)
  33 :         INTEGER FWORK
  34 :         INTEGER TWORK(NTROU)
  35 :       ENDSEGMENT
  36 :       POINTEUR WWORK1.WWORK
  37 : C
  38 :       SEGMENT VWORK
  39 :         INTEGER FWWORK(NFACE)
  40 :       ENDSEGMENT
  41 : C
  42 :       LOGICAL LAINB,LAOUB,LAONB,LBINA,LBOUA,LBONA
  43 : C
  44 :       NTROU1=WWORK1.TWORK(/1)
  45 :       NFACE=FWWORK(/1)
  46 : C
  47 : C     ON BOUCLE SUR LES NOUVELLES FACES ET ON EN EXTRAIT WORK QUE L'ON
  48 : C     PLACE EN A (WORK1)
  49 : C
  50 :       NFACE=FWWORK(/1)
  51 :       DO IE1=1,NFACE
  52 :         IFACE=NFACE-IE1+1
  53 :         WWORK=FWWORK(IFACE)
  54 :         NTROU=TWORK(/1)
  55 :         IF(NTROU.NE.0)THEN
  56 :           IRET=IRET+1
  57 :           WRITE(IOIMP,*)'J3COAK: LE NOMBRE DE TROUS DANS LES NOUVELLES'
  58 :           WRITE(IOIMP,*)'        FACES DOIT ETRE NUL'
  59 :           RETURN
  60 :         ENDIF
  61 :         WORK1=FWORK
  62 : C
  63 : C     ON BOUCLE SUR LES TROUS DE A QUE L"ON PLACE EN B (WORK2)
  64 : C
  65 :         DO IE2=1,NTROU1
  66 :           WORK2=WWORK1.TWORK(IE2)
  67 : C
  68 : C     SI LE TROU EST ENCORE ACTIF ON REGARDE S'IL EST STRICTEMENT CONTENU
  69 : C     DANS A (en 98 on adoucit au cas sur les bord!!!)
  70 : C
  71 :           IF(WORK2.NE.0)THEN
  72 : CPP???
  72 :             CALL J3COTO(WORK2,WORK1,TOL,IRET)
  73 : CPP???
  73 :             CALL J3COTO(WORK1,WORK2,TOL,IRET)
  74 :             IF(IRET.NE.0)RETURN
  75 :             NPTO1=WORK1.XYC(/2)
  75 :             CALL J3TES1(WORK1.IST,NPTO1,LAINB,LAOUB,LAONB,NAONB)
  76 :             NPTO2=WORK2.XYC(/2)
  76 :             CALL J3TES1(WORK2.IST,NPTO2,LBINA,LBOUA,LBONA,NBONA)
  77 : C pp98        IF(LBINA)THEN
  78 :               IF(.NOT.LBOUA)THEN
  79 : C pp98        IF(LBONA)THEN
  80 : C pp98          IRET=IRET+1
  81 : C pp98          WRITE(IOIMP,*)'J3COAK: A NE PEUT PAS ETRE SUR B'
  82 : C pp98          RETURN
  83 : C
  84 : C     SI OUI, ON BOUGE LE TROU DANS LA NOUVELLE FACE
  85 : C
  86 : C pp98        ELSE
  87 :                 NTROU=NTROU+1
  88 :                 SEGADJ,WWORK
  89 :                 TWORK(NTROU)=WORK2
  90 :                 WWORK1.TWORK(IE2)=0
  91 : C pp98        ENDIF
  92 :             ENDIF
  93 :           ENDIF
  94 :         ENDDO
  95 :       ENDDO
  96 : C
  97 :       RETURN
  98 :       END
  99 :  
 100 :