Télécharger combl2.eso

Retour à la liste

Numérotation des lignes :

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

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