Esope source files

   1 : C J3ARET    SOURCE    CHAT      05/01/13    00:45:53     5004           
   2 :       SUBROUTINE J3ARET(BLOCOM,TOL)
   3 : C--------------------------------------------------------------------
   4 : C
   5 : C     ADDITION DES POINTS SUR LES ARRETES
   6 : C
   7 : C     PP /9/97
   8 : C     Pierre Pegon/JRC Ispra
   9 : C--------------------------------------------------------------------
  10 :       IMPLICIT INTEGER(I-N)
  11 :       IMPLICIT REAL*8 (A-H,O-Z)
  12 : C
  13 : -INC CCOPTIO
  14 : -INC SMELEME
  15 : C
  16 :       SEGMENT BLOCOM
  17 :         INTEGER POINT(NPOINT)
  18 :         REAL*8 YCOOR(IDIM+1,NPOINT)
  19 :         INTEGER MAILL(MM1)
  20 :       ENDSEGMENT
  21 : C
  22 :       DIMENSION V1(3),V2(3),VI(3)
  23 : C
  24 :       IF(IDIM.EQ.2)THEN
  25 :         V1(3)=0.D0
  26 :         V2(3)=0.D0
  27 :         VI(3)=0.D0
  28 :       ENDIF
  29 : C
  30 :       MM1=MAILL(/1)
  31 :       NPOINT=POINT(/1)
  32 :       TOL2=TOL**2
  33 : C
  34 : C     ON BOUCLE SUR TOUS LES CONTOURS
  35 : C
  36 :       NBSOUS=0
  37 :       NBREF=0
  38 :       NBNN=2
  39 :       DO IE1=1,MM1
  40 :         MELEME=MAILL(IE1)
  41 :         NBELEM=ICOLOR(/1)
  42 : C
  43 : C     ... ET SUR TOUS LEURS COTES
  44 : C     (ON SIMULE "DO 3 IE2=1,NBELEM" AVEC IE2 ET NBELEM EVENTUELLEMENT CHANGES)
  45 : C
  46 :         IE2=0
  47 :  1      IE2=IE2+1
  48 :         IF(IE2.GT.NBELEM)GOTO 3
  49 : C       DO IE2=1,NBELEM
  50 :           D12=0.D0
  51 :           DO IE3=1,IDIM
  52 :             V1(IE3)=YCOOR(IE3,NUM(1,IE2))
  53 :             V2(IE3)=YCOOR(IE3,NUM(2,IE2))
  54 :             D12=D12+(V1(IE3)-V2(IE3))**2
  55 :           ENDDO
  56 : C
  57 : C     ON BOUCLE SUR TOUS LES POINTS ...
  58 : C
  59 :           DO 2 IE3=1,NPOINT
  60 :             DI1=0.D0
  61 :             DI2=0.D0
  62 :             DO IE4=1,IDIM
  63 :               VI(IE4)=YCOOR(IE4,POINT(IE3))
  64 :               DI1=DI1+(VI(IE4)-V1(IE4))**2
  65 :               DI2=DI2+(VI(IE4)-V2(IE4))**2
  66 :             ENDDO
  67 : C
  68 : C     ... ON ELIMINE CEUX QUI SONT TROP LOIN ...
  69 : C
  70 :             IF((DI1.GT.D12+TOL2).OR.(DI2.GT.D12+TOL2))GOTO 2
  71 : C
  72 : C     ... ON ELIMINE CEUX QUI SONT TROP PRES ...
  73 : C
  74 :             IF((DI1.LT.TOL2).OR.(DI2.LT.TOL2))GOTO 2
  75 : C
  76 : C     ... CEUX QUI NE SONT PAS ENTRE ...
  77 : C
  78 :             AAA=0.D0
  79 :             DO IE4=1,IDIM
  80 :               AAA=AAA+(VI(IE4)-V1(IE4))*(V2(IE4)-V1(IE4))
  81 :             ENDDO
  82 :             AAA=AAA/D12
  83 :             IF(AAA.LT.0.D0.OR.AAA.GT.1.D0)GOTO 2
  84 : C
  85 : C     ... ET CEUX QUI SONT TROP LOIN DU SEGMENT
  86 : C
  87 :             BBB=0.D0
  88 :             DO IE4=1,IDIM
  89 :               BBB=BBB+(VI(IE4)-V1(IE4)-AAA*(V2(IE4)-V1(IE4)))**2
  90 :             ENDDO
  91 :             IF(BBB.GT.TOL2)GOTO 2
  92 : C
  93 : C     ON INCERE LES POINT RESTANT DANS LE MAILLAGE 
  94 : C     WARNING: ON LE FAIT SANS DUPLICATION
  95 : C
  96 :             NBELEM=NBELEM+1
  97 :             SEGADJ, MELEME
  98 :             ICOLOR(NBELEM)=ICOLOR(NBELEM-1)
  99 :             IF(IE2.LT.NBELEM)THEN
 100 :               DO IE4=NBELEM,IE2+1,-1
 101 :                 NUM(1,IE4)=NUM(1,IE4-1)
 102 :                 NUM(2,IE4)=NUM(2,IE4-1)
 103 :               ENDDO
 104 :             ENDIF
 105 :             NUM(2,IE2  )=POINT(IE3)
 106 :             NUM(1,IE2+1)=POINT(IE3)
 107 : 
 108 : C     ... ET ON REPASSE PAR LE NOUVEAU SEGMENT EN SORTANT DE LA BOUCLE POINT
 109 : C
 110 :             IE2=IE2-1
 111 :             GOTO 1
 112 : C
 113 : C     FIN BOUCLE POINT
 114 : C
 115 :  2        CONTINUE
 116 : C
 117 : C     FIN BOUCLE COTE
 118 : C
 119 :           GOTO 1
 120 :  3      CONTINUE
 121 : C
 122 : C     FIN BOUCLE FACE
 123 : C
 124 :       ENDDO
 125 : C
 126 :       RETURN
 127 :       END
 128 :  
 129 :