Télécharger j3unlo.eso

Retour à la liste

Numérotation des lignes :

  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.  
  154.  

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