Télécharger combl2.eso

Retour à la liste

Numérotation des lignes :

  1. C COMBL2 SOURCE CHAT 06/03/16 21:15:21 5336
  2. SUBROUTINE COMBL2
  3. C--------------------------------------------------------------------
  4. C
  5. C TABL1 = COMB TABL2 FLOT1;
  6. C
  7. C FLOT1 : TOLERANCE
  8. C
  9. C Pierre Pegon/JRC Ispra (??96 et 12/98)
  10. C--------------------------------------------------------------------
  11. IMPLICIT INTEGER(I-N)
  12. IMPLICIT REAL*8 (A-H,O-Z)
  13. C
  14. -INC CCOPTIO
  15. -INC SMTABLE
  16. -INC SMELEME
  17. -INC SMCOORD
  18. -INC CCNOYAU
  19. -INC CCASSIS
  20. C
  21. C2002 SEGMENT,BLOCOM
  22. C2002 INTEGER POINT(NPOINT)
  23. C2002 REAL*8 XX(NPOINT),YY(NPOINT),DD(NPOINT)
  24. C2002 INTEGER MAILL(MM1)
  25. C2002 ENDSEGMENT
  26. C
  27. SEGMENT BLOCOM
  28. INTEGER POINT(NPOINT)
  29. REAL*8 YCOOR(IDIM+1,NPOINT)
  30. INTEGER MAILL(MM1)
  31. ENDSEGMENT
  32. C
  33. CALL LIROBJ('TABLE',MTABLE,1,IRETOU)
  34. IF(IERR.NE.0) RETURN
  35. CALL LIRREE(XTOL,1,IRETOU)
  36. IF(IERR.NE.0) RETURN
  37. XTOL2=XTOL**2
  38. C
  39. C VERIFICATION DE LA DIMENSION
  40. C
  41. IF (IDIM.NE.2)THEN
  42. WRITE(IOIMP,*)'GENJOI: on n"est pas en 2D'
  43. RETURN
  44. ENDIF
  45. C
  46. C VERIFICATIONS DIVERSES
  47. C - SOUS TYPE DE LA TABLE
  48. C - NATURE DES MAILLAGE DE LA TABLE (SIMPLE, POI1 OU SEG2)
  49. C ET CALCUL DU NOMBRE DE POINT
  50. C
  51. NPOINT=0
  52. SEGACT, MTABLE
  53. MM=MLOTAB
  54. if(nbesc.ne.0) segact ipiloc
  55. DO IE1=1,MM
  56. IF (MTABTI(IE1).EQ.'MOT ')THEN
  57. C
  58. C ON VERIFIE LA VALEUR DE L'INDICE MOT ET LE CONTENU
  59. C
  60. JF=IPCHAR(MTABII(IE1)+1)
  61. ID=IPCHAR(MTABII(IE1))
  62. IF (ICHARA(ID:JF-1).NE.'SOUSTYPE')THEN
  63. WRITE(IOIMP,*)'COMB: un indice de type mot est errone'
  64. GOTO 9999
  65. ENDIF
  66. IF (MTABTV(IE1).NE.'MOT ')THEN
  67. WRITE(IOIMP,*)'COMB: le SOUSTYPE doit etre un MOT'
  68. GOTO 9999
  69. ENDIF
  70. JF=IPCHAR(MTABIV(IE1)+1)
  71. ID=IPCHAR(MTABIV(IE1))
  72. IF (ICHARA(ID:JF-1).NE.'LISTE_DE_BLOCS')THEN
  73. WRITE(IOIMP,*)'COMB: le SOUSTYPE doit etre LISTE_DE_BLOCS'
  74. GOTO 9999
  75. ENDIF
  76. ELSEIF (MTABTI(IE1).EQ.'ENTIER ')THEN
  77. C
  78. C ON VERIFIE LE CONTENU DES INDICES ENTIERS
  79. C
  80. IF (MTABTV(IE1).NE.'MAILLAGE')THEN
  81. ENDIF
  82. MELEME=MTABIV(IE1)
  83. SEGACT,MELEME
  84. IF(LISOUS(/1).NE.0.OR.(ITYPEL.NE.1.AND.ITYPEL.NE.2))THEN
  85. WRITE(IOIMP,*)'COMB: un maillage est errone'
  86. SEGDES,MELEME
  87. GOTO 9999
  88. ENDIF
  89. NPOINT=NPOINT+ICOLOR(/1)
  90. SEGDES,MELEME
  91. ELSE
  92. WRITE(IOIMP,*)'COMB: un type d"indice est errone'
  93. GOTO 9999
  94. ENDIF
  95. ENDDO
  96. if(nbesc.ne.0) segdes ipiloc
  97. C
  98. C ON CHARGE LE NUMERO DES POINTS ...
  99. C
  100. IPOINT=0
  101. IMAILL=0
  102. MM1=MM-1
  103. SEGINI,BLOCOM
  104. DO IE1=1,MM
  105. IF (MTABTI(IE1).EQ.'ENTIER ')THEN
  106. IMAILL=IMAILL+1
  107. MELEME=MTABIV(IE1)
  108. MAILL(IMAILL)=MELEME
  109. SEGACT,MELEME
  110. DO IE2=1,ICOLOR(/1)
  111. IPOINT=IPOINT+1
  112. POINT(IPOINT)=NUM(1,IE2)
  113. ENDDO
  114. SEGDES,MELEME
  115. ENDIF
  116. ENDDO
  117. C
  118. C ... ON LES ORDONNE ...
  119. C
  120. CALL ORDO02(POINT,NPOINT,.TRUE.)
  121. C
  122. C ... ET ON VERIFIE QU'ILS SONT TOUS 2 A 2 DIFFERENT
  123. C
  124. IPOINT=POINT(1)
  125. DO IE1=2,NPOINT
  126. IPOIN1=POINT(IE1)
  127. IF(IPOIN1.EQ.IPOINT)THEN
  128. WRITE(IOIMP,*)'COMB: deux points sont identiques'
  129. GOTO 9998
  130. ENDIF
  131. IPOINT=IPOIN1
  132. ENDDO
  133. C
  134. C ON CHARGES LES COORDONNES ET LA DENSITE DE TOUS LES POINTS
  135. C
  136. DO IE1=1,NPOINT
  137. IREF=(POINT(IE1)-1)*(IDIM+1)
  138. C2002 XX(IE1)=XCOOR(IREF+1)
  139. C2002 YY(IE1)=XCOOR(IREF+2)
  140. C2002 DD(IE1)=XCOOR(IREF+3)
  141. DO IE2=1,IDIM+1
  142. YCOOR(IE2,IE1)=XCOOR(IREF+IE2)
  143. ENDDO
  144. ENDDO
  145. C+2002
  146. C
  147. C ON VERIFIE QUE LES POINTS EN VIS A VIS ONT LA MEME DENSITE
  148. C ET ON REND LES COORDONNES IDENTIQUES
  149. C
  150. IRETOU=0
  151. CALL J3DISK(BLOCOM,XTOL,IRETOU)
  152. IF(IRETOU.NE.0)THEN
  153. WRITE(IOIMP,*)'COMBL2: Pbs de pt en vis-a-vis'
  154. GOTO 9998
  155. ENDIF
  156. C
  157. SEGACT MCOORD*MOD
  158. DO IE1=1,NPOINT
  159. IREF=(POINT(IE1)-1)*(IDIM+1)
  160. DO IE2=1,IDIM+1
  161. XCOOR(IREF+IE2)=YCOOR(IE2,IE1)
  162. ENDDO
  163. ENDDO
  164. C+2002
  165. C
  166. C ON BOUCLE MAINTENANT SUR TOUS LES BLOCS ...
  167. C
  168. NBSOUS=0
  169. DO IE1=1,MM1
  170. MELEME=MAILL(IE1)
  171. SEGACT,MELEME
  172. NBNN=ITYPEL
  173. NBELEM=ICOLOR(/1)
  174. NBREF=LISREF(/1)
  175. C
  176. C ... ET SUR TOUS LEURS COTES
  177. C (ON SIMULE "DO 3 IE2=1,NBELEM" AVEC IE2 ET NBELEM EVENTUELLEMENT CH
  178. C
  179. IE2=0
  180. 1 IE2=IE2+1
  181. IF(IE2.GT.NBELEM)GOTO 3
  182. C DO 3 IE2=1,NBELEM
  183. IREF=(NUM(1,IE2)-1)*(IDIM+1)
  184. XX1=XCOOR(IREF+1)
  185. YY1=XCOOR(IREF+2)
  186. IF(IE2.EQ.NBELEM)THEN
  187. IREF=(NUM(1,1)-1)*(IDIM+1)
  188. ELSE
  189. IREF=(NUM(1,IE2+1)-1)*(IDIM+1)
  190. ENDIF
  191. XX2=XCOOR(IREF+1)
  192. YY2=XCOOR(IREF+2)
  193. D12=(XX1-XX2)**2+(YY1-YY2)**2
  194. C
  195. C ON BOUCLE SUR TOUS LES POINTS ...
  196. C
  197. DO 2 IE3=1,NPOINT
  198. C2002 XXI=XX(IE3)
  199. C2002 YYI=YY(IE3)
  200. XXI=YCOOR(1,IE3)
  201. YYI=YCOOR(2,IE3)
  202. DI1=(XXI-XX1)**2+(YYI-YY1)**2
  203. DI2=(XXI-XX2)**2+(YYI-YY2)**2
  204. C
  205. C ... ON ELIMINE CEUX QUI SONT TROP LOIN ...
  206. C
  207. IF((DI1.GT.D12+XTOL2).OR.(DI2.GT.D12+XTOL2))GOTO 2
  208. C
  209. C ... ON ELIMINE CEUX QUI SONT TROP PRES ...
  210. C
  211. IF((DI1.LT.XTOL2).OR.(DI2.LT.XTOL2))GOTO 2
  212. C
  213. C ... CEUX QUI NE SONT PAS ENTRE ...
  214. C
  215. AAA=((XXI-XX1)*(XX2-XX1)+(YYI-YY1)*(YY2-YY1))/D12
  216. IF(AAA.LT.0.D0.OR.AAA.GT.1.D0)GOTO 2
  217. C
  218. C ... ET CEUX QUI SONT TROP LOIN DU SEGMENT
  219. C
  220. BBB=((XXI-XX1)-AAA*(XX2-XX1))**2
  221. > +((YYI-YY1)-AAA*(YY2-YY1))**2
  222. IF(BBB.GT.XTOL2)GOTO 2
  223. C
  224. C ON INCERE LES POINT RESTANT DANS LE MAILLAGE APRES DUPLICATION
  225. C EVENTUELLE ...
  226. C
  227. C PP 2001: On change un peu la filosophie: on incere le point du segm
  228. C le plus proche du point conside. Cela ne change rien si le
  229. C sont sans epaisseurs...
  230. C
  231. C
  232. NBPTS=XCOOR(/1)/(IDIM+1)+1
  233. SEGADJ MCOORD
  234. IREF=(NBPTS-1)*(IDIM+1)
  235. C PP20001 XCOOR(IREF+1)=XXI
  236. C PP20001 XCOOR(IREF+2)=YYI
  237. XCOOR(IREF+1)=XX1+AAA*(XX2-XX1)
  238. XCOOR(IREF+2)=YY1+AAA*(YY2-YY1)
  239. C PP20001
  240. C 2002 XCOOR(IREF+3)=DD(IE3)
  241. XCOOR(IREF+3)=YCOOR(IDIM+1,IE3)
  242. IF(MELEME.EQ.MAILL(IE1))THEN
  243. IPT1=MELEME
  244. SEGINI,MELEME=IPT1
  245. SEGDES,IPT1
  246. ENDIF
  247. NBELEM=NBELEM+1
  248. SEGADJ, MELEME
  249. ICOLOR(NBELEM)=ICOLOR(NBELEM-1)
  250. IF(ITYPEL.EQ.1)THEN
  251. IF(IE2.LT.NBELEM-1)THEN
  252. DO IE4=NBELEM,IE2+2,-1
  253. NUM(1,IE4)=NUM(1,IE4-1)
  254. ENDDO
  255. ENDIF
  256. NUM(1,IE2+1)=NBPTS
  257. ELSE
  258. DO IE4=NBELEM,IE2+1,-1
  259. NUM(1,IE4)=NUM(1,IE4-1)
  260. NUM(2,IE4)=NUM(2,IE4-1)
  261. ENDDO
  262. NUM(1,IE2+1)=NBPTS
  263. NUM(2,IE2)=NBPTS
  264. ENDIF
  265.  
  266. C
  267. C ... ET ON REPASSE PAR LE NOUVEAU SEGMENT EN SORTANT DE LA BOUCLE PO
  268. C
  269. IE2=IE2-1
  270. GOTO 1
  271. C
  272. C FIN BOUCLE POINT
  273. C
  274. 2 CONTINUE
  275. C
  276. C FIN BOUCLE COTE
  277. C
  278. GOTO 1
  279. 3 CONTINUE
  280. IF(MELEME.EQ.MAILL(IE1))THEN
  281. SEGDES,MELEME
  282. ELSE
  283. MAILL(IE1)=MELEME
  284. SEGDES,MELEME
  285. ENDIF
  286. C
  287. C FIN BOUCLE BLOC
  288. C
  289. ENDDO
  290. C
  291. C ON CREE ET ON REMPLIT LA TABLE DE SORTIE
  292. C
  293. IMAILL=0
  294. MTAB1=MTABLE
  295. SEGINI,MTABLE=MTAB1
  296. SEGDES,MTAB1
  297. DO IE1=1,MM
  298. IF (MTABTI(IE1).EQ.'ENTIER ')THEN
  299. IMAILL=IMAILL+1
  300. MTABIV(IE1)=MAILL(IMAILL)
  301. ENDIF
  302. ENDDO
  303. C
  304. C ON REND LA MAIN A GIBIANE
  305. C
  306. SEGSUP,BLOCOM
  307. SEGDES,MTABLE
  308. CALL ECROBJ('TABLE',MTABLE)
  309. C
  310. RETURN
  311. C
  312. C ERREURS
  313. C
  314. 9998 SEGSUP,BLOCOM
  315. 9999 SEGDES,MTABLE
  316. RETURN
  317. END
  318.  
  319.  

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