Esope source files

   1 : C J3UNLO    SOURCE    CHAT      05/01/13    00:47:40     5004           
   2 :       SUBROUTINE J3UNLO(BLOCOM,BLOCO1,MTABLE,TOL)
   3 : C--------------------------------------------------------------------
   4 : C
   5 : C     CHARGEMENT DES POINTS AVEC ELIMINATION AVEC LES POINTS
   6 : C                ORIGINAUX
   7 : C
   8 : C     PP /9/97
   9 : C     Pierre Pegon/JRC Ispra
  10 : C--------------------------------------------------------------------
  11 :       IMPLICIT INTEGER(I-N)
  12 :       IMPLICIT REAL*8 (A-H,O-Z)
  13 : C
  14 : -INC CCOPTIO
  15 : -INC SMELEME
  16 : -INC SMTABLE
  17 : -INC SMCOORD
  18 : C
  19 :       SEGMENT BLOCOM
  20 :         INTEGER POINT(NPOINT)
  21 :         REAL*8 YCOOR(IDIM+1,NPOINT)
  22 :         INTEGER MAILL(MM1)
  23 :       ENDSEGMENT
  24 :       POINTEUR BLOCO1.BLOCOM
  25 : C
  26 :       DIMENSION Y3(4)
  27 : C
  28 :       SEGACT,MCOORD*MOD
  29 : C
  30 :       TOL2=TOL**2
  31 :       MM1=MLOTAB
  32 : C
  33 : C     BOUCLE SUR LES BLOCKS (SEULS LES INDICES ENTIERS ... IIE1)
  34 : C     WARNING: IPOI DEBUT DES POINTS ORIGINAUX DANS BLOCO1
  35 : C              IPOF FIN DES POINT ORIGINAUX DANS BLOCO1
  36 : C
  37 :       IIE1=0
  38 :       IPOI=1
  39 :       DO IE1=1,MM1
  40 :         IF (MTABTI(IE1).EQ.'ENTIER  ')THEN
  41 :           IIE1=IIE1+1
  42 :           IPOF=BLOCO1.MAILL(IIE1)
  43 :           MTAB1=MTABIV(IE1)
  44 :           MM2=MTAB1.MLOTAB
  45 : C
  46 : C     BOUCLE SUR LES FACES (SEULS LES INDICES ENTIERS ... )
  47 : C
  48 :           DO IE2=1,MM2
  49 :             IF (MTAB1.MTABTI(IE2).EQ.'ENTIER  ')THEN
  50 :               MELEME=MTAB1.MTABIV(IE2)
  51 :               NBELEM=ICOLOR(/1)
  52 : C
  53 : C     BOUCLE SUR LES ELEMENTS DES FACES EN PARTICULIER LES 1ER POINTS
  54 : C
  55 :               ITROU=1
  56 :               DO IE3=1,NBELEM
  57 :                 IPO3=NUM(1,IE3)
  58 :                 DO IE4=1,IDIM+1
  59 :                   Y3(IE4)=YCOOR(IE4,IPO3)
  60 :                 ENDDO
  61 : C
  62 : C     ON REGARDE SI CE POINT PEUT ETRE CONFONDU AVEC UN POINT ORIGINAL
  63 : C
  64 :                 DO IE4=IPOI,IPOF
  65 :                   NUME=BLOCO1.POINT(IE4)
  66 :                   IREF=(NUME-1)*(IDIM+1)
  67 :                   AAA=0.D0
  68 :                   DO IE5=1,IDIM
  69 :                     AAA=AAA+(XCOOR(IE5+IREF)-Y3(IE5))**2
  70 :                   ENDDO
  71 :                   IF(AAA.LT.TOL2)GOTO 1
  72 :                 ENDDO
  73 : C
  74 : C     SI CE N'EST PAS LE CAS, ON L'AJOUTE ...
  75 : C
  76 :                 NBPTS=XCOOR(/1)/(IDIM+1)+1
  77 :                 IREF=(NBPTS-1)*(IDIM+1)
  78 :                 NUME=NBPTS
  79 :                 SEGADJ,MCOORD
  80 : C
  81 : C     ... MAIS ON AJOURNE DANS TOUS LES CAS LES COORDONNEES (SURF+DISK!)
  82 : C
  83 :  1              CONTINUE              
  84 :                 DO IE4=1,IDIM+1
  85 :                   XCOOR(IE4+IREF)=Y3(IE4)
  86 :                 ENDDO
  87 : C
  88 : C     ON STOCKE LA REFERENCE AU NIVEAU DE LA FACE (ATTENTION AU TROU!)
  89 : C
  90 :                 NUM(1,IE3)=NUME
  91 :                 IF(IE3.EQ.1)THEN
  92 :                   ICAND=NBELEM
  93 :                 ELSE
  94 :                   ICAND=IE3-1
  95 :                 ENDIF
  96 :                 IF(NUM(2,ICAND).EQ.IPO3)THEN
  97 :                   NUM(2,ICAND)=NUME
  98 :                 ELSE
  99 :                   DO IE4=ITROU,NBELEM
 100 :                     IF(NUM(2,IE4).EQ.IPO3)GOTO 2
 101 :                   ENDDO
 102 :                   WRITE(IOIMP,*)'J3UNLO: IMPOSSIBLE !!!!'
 103 :  2                CONTINUE
 104 :                   ITROU=IE4+1
 105 :                   NUM(2,IE4)=NUME
 106 :                 ENDIF
 107 : C
 108 : C     FIN LOOP ELEMENT DE LA FACE
 109 : C
 110 :               ENDDO
 111 : C
 112 : C     ON RE-LOOP SUR LA FACE POUR AJOUTER DES POINTS REDONDANT (SURF!)
 113 : C
 114 :               DO IE3=1,NBELEM-1
 115 :                 IPO3=NUM(1,IE3)
 116 :                 IREF3=(IPO3-1)*(IDIM+1)
 117 :                 DO IE4=IE3+1,NBELEM
 118 :                   IF(NUM(1,IE4).EQ.IPO3)THEN
 119 :                     NBPTS=XCOOR(/1)/(IDIM+1)+1
 120 :                     IREF=(NBPTS-1)*(IDIM+1)
 121 :                     SEGADJ,MCOORD
 122 :                     DO IE5=1,IDIM+1
 123 :                       XCOOR(IE5+IREF)=XCOOR(IE5+IREF3)
 124 :                     ENDDO
 125 :                     NUM(1,IE4)=NBPTS
 126 :                     IF(NUM(2,IE4-1).NE.IPO3)THEN
 127 :                       WRITE(IOIMP,*)'J3UNLO: IMPOSSIBLE (bis) !!!!'
 128 :                     ENDIF
 129 :                     NUM(2,IE4-1)=NBPTS
 130 :                   ENDIF
 131 :                 ENDDO
 132 :               ENDDO
 133 : C
 134 : C     FIN LOOP FACE
 135 : C
 136 :               SEGDES,MELEME
 137 :             ENDIF
 138 :           ENDDO
 139 : C
 140 : C     FIN LOOP BLOCK
 141 : C
 142 :           SEGDES,MTAB1
 143 :           IPOI=IPOF+1
 144 :         ENDIF
 145 :       ENDDO
 146 :       SEGDES,MTABLE
 147 : C
 148 :       SEGACT,MCOORD
 149 : C
 150 :       RETURN
 151 :       END
 152 :  
 153 :