Esope source files

   1 : C J3MUFA    SOURCE    CHAT      05/01/13    00:47:05     5004           
   2 :       SUBROUTINE J3MUFA(VWORK,TOL,IRET)
   3 : C----------------------------------------------------
   4 : C     SPLITTING D'UN CONTOUR EN PLUSIEURS SI
   5 : C     IL Y A DES PTS COMMUNS
   6 : C
   7 : C     PP 12/98
   8 : C     Pierre Pegon/JRC Ispra
   9 : C----------------------------------------------------
  10 :       IMPLICIT INTEGER(I-N)
  11 :       IMPLICIT REAL*8(A-H,O-Z)
  12 :       DIMENSION XY(2)
  13 : -INC  CCOPTIO

  14 : C
  15 :       SEGMENT VWORK
  16 :         INTEGER FWWORK(NFACE)
  17 :       ENDSEGMENT
  18 :       POINTEUR VWORK1.VWORK,VWORK2.VWORK,VWDUMM.VWORK
  19 : C
  20 :       SEGMENT WWORK
  21 :         REAL*8 PORIG(3),VNORM(3),VI(3),VJ(3)
  22 :         INTEGER FWORK
  23 :         INTEGER TWORK(NTROU)
  24 :       ENDSEGMENT
  25 :       POINTEUR WWORK1.WWORK
  26 : C
  27 :       SEGMENT WORK
  28 :         REAL*8 XYC(2,NPTO)
  29 :         INTEGER IST(3,NPTO)
  30 :         REAL*8 DENS(NPTO)
  31 :         INTEGER JUN
  32 :       ENDSEGMENT
  33 :       POINTEUR WORK1.WORK,WORK2.WORK,WORK3.WORK
  34 : C
  35 :       NFACE=FWWORK(/1)
  36 :       IF(NFACE.NE.1)THEN
  37 :         WRITE(IOIMP,*)
  38 :      >  'J3MUFA: La face ne doit contenir qu"un seul contour'
  39 :         IRET=IRET+1
  40 :         RETURN
  41 :       ENDIF
  42 : C
  43 :       WWORK=FWWORK(1)
  44 :       NTROU= TWORK(/1)
  45 :       IF(NTROU.NE.0)THEN
  46 :         WRITE(IOIMP,*)
  47 :      >  'J3MUFA: Le contour ne doit pas contenir de trou'
  48 :         IRET=IRET+1
  49 :         RETURN
  50 :       ENDIF
  51 : C
  52 :       WORK=FWORK
  53 :       NPTO=XYC(/2)
  53 :       CALL J3ZERI(IST,3,NPTO)
  54 :       DO 1 IE1=1,NPTO-1
  55 :         XX=XYC(1,IE1)
  56 :         YY=XYC(2,IE1)
  57 :         DO IE2=IE1+1,NPTO
  58 :           DO IE3=1,2
  59 :             XY(IE3)=XYC(IE3,IE2)
  60 :           ENDDO
  61 :           DIS=SQRT((XX-XY(1))**2+(YY-XY(2))**2)
  62 :           IF(DIS.LT.TOL)THEN
  63 :             NFACE=NFACE+1
  64 :             IST(1,IE1)=IE2
  65 :             GOTO 1
  66 :           ENDIF
  67 :         ENDDO
  68 :  1    CONTINUE
  69 : C
  70 :       IF(NFACE.EQ.1)RETURN
  71 : C
  72 :       SEGADJ,VWORK
  73 :       SEGINI,WORK1
  74 :       FWORK=WORK1
  75 :       IE1=0
  76 :       JE1=0
  77 :       NNFACE=1
  78 : C     DO 2 IE1=1,NPTO
  79 :  2    CONTINUE
  80 :         IE1=IE1+1
  81 :         IF(IE1.GT.NPTO)GOTO 3
  82 :         JE1=JE1+1
  83 :         DO IE2=1,2
  84 :           WORK1.XYC(IE2,JE1)=XYC(IE2,IE1)
  85 :         ENDDO
  86 :         IF(IST(1,IE1).EQ.0)THEN
  87 :           DO IE2=1,2
  88 :             WORK1.XYC(IE2,JE1)=XYC(IE2,IE1)
  89 :           ENDDO
  90 :         ELSE
  91 :           NPTO=IST(1,IE1)-IE1
  92 :           SEGINI,WWORK,WORK2
  93 :           FWORK=WORK2
  94 :           NNFACE=NNFACE+1
  95 :           FWWORK(NNFACE)=WWORK
  96 :           DO IE2=IE1+1,IST(1,IE1)
  97 :             DO IE3=1,2
  98 :               WORK2.XYC(IE3,IE2-IE1)=XYC(IE3,IE1)
  99 :             ENDDO
 100 :           ENDDO
 101 :           IE1=IST(1,IE1)-1
 102 :         ENDIF
 103 :       GOTO 2
 104 :  3    CONTINUE
 105 :       IF(NNFACE.NE.NFACE)THEN
 106 : C        ...........!!!!!!!!!!!!
 107 :       ENDIF
 108 :       NPTO=JE1
 109 :       SEGADJ,WORK1
 110 : C
 111 :       SEGSUP,WORK
 112 : C
 113 :       RETURN
 114 :       END
 115 :  
 116 : 
 117 :  
 118 :