Télécharger ijet.eso

Retour à la liste

Numérotation des lignes :

  1. C IJET SOURCE BP208322 16/11/18 21:17:35 9177
  2. C IJET SOURCE PM 01/12/11 21:44:48 4041
  3. SUBROUTINE IJET
  4. CA Ph. MIRANDA
  5. CD 30/11/2001
  6. CC--------------------------------------------------------------------------
  7. CC
  8. CC Le sous-programme IJET calcule par une methode analytique exacte
  9. CC l'intersection entre des segments (connus par les coordonnees de
  10. CC leurs extremites) et les facettes triangulaires d'un maillage
  11. CC (connues par les coordonnees de leurs 3 extremites et leurs
  12. CC normales). De plus, ce programme permet de deduire les valeurs
  13. CC d'un champ appuye sur les noeuds du maillage aux points
  14. CC d'intersection des segments par interpolation.
  15. CC
  16. CC IJET reprend les fonctionnalites de la procedure GIBIANE @INTSEC
  17. CC inspiree de @INTERC concue par R.Mitteau (CEA/DSM/DRFC) et
  18. CC B.Riou (CSSI) en oct 1998.
  19. CC
  20. CC version initiale : Ph.Miranda (CSSI) en nov 2001
  21. CC modification : T.Charras (CEA/DM2S) en oct 2003
  22. CC modification : A.Moal (CSSI) en jan 2004
  23. CC
  24. CC Syntaxe generale :
  25. CC
  26. CC CHDIST MINTER CHFN CHDEP = IJET CHOLD CHNEW TOL TAB1 ;
  27. CC
  28. CC--------------------------------------------------------------------------
  29. CE En entree :
  30. CE
  31. CE CHOLD : coordonnees des points extremites initiales des segments
  32. CE (type CHPOINT a 3 composantes)
  33. CE CHNEW : coordonnees des points extremites finales des segments
  34. CE (type CHPOINT a 3 composantes appuye sur le meme support
  35. CE que CH_OLD)
  36. CE TOL : tolerance (type FLOTTANT)
  37. CE TAB1 : Table qui doit contenir les parametres suivants en entree
  38. CE
  39. CE <chamx1 (type MCHAML) coordonnee x du premier noeud de l'element
  40. CE <chamy1 (type MCHAML) coordonnee y du premier noeud de l'element
  41. CE <chamz1 (type MCHAML) coordonnee z du premier noeud de l'element
  42. CE
  43. CE <chamx2 (type MCHAML) coordonnee x du deuxieme noeud de l'element
  44. CE <chamy2 (type MCHAML) coordonnee y du deuxieme noeud de l'element
  45. CE <chamz2 (type MCHAML) coordonnee z du deuxieme noeud de l'element
  46. CE
  47. CE <chamx3 (type MCHAML) coordonnee x du troisieme noeud de l'element
  48. CE <chamy3 (type MCHAML) coordonnee y du troisieme noeud de l'element
  49. CE <chamz3 (type MCHAML) coordonnee z du troisieme noeud de l'element
  50. CE
  51. CE <chamf1 (type MCHAML) flux au premier noeud de l'element
  52. CE <chamf2 (type MCHAML) flux au second noeud de l'element
  53. CE <chamf3 (type MCHAML) flux au troisieme noeud de l'element
  54. CE
  55. CE <cosx (type MCHAML) cosinus directeur selon x
  56. CE <cosy (type MCHAML) cosinus directeur selon y
  57. CE <cosz (type MCHAML) cosinus directeur selon z
  58. CC
  59. CS En sortie :
  60. CS
  61. CS CHDIST : CHPOINT appuye sur le support de CHOLD et contenant
  62. CS le pas si pas d'intersection et la distance entre
  63. CS point initial du segment et le point d'intersection
  64. CS a la facette sinon (type CHPOINT)
  65. CS MINTER : contient les noeuds intersectes du support de CHOLD.
  66. CS (type MAILLAGE)
  67. CS CHFN : CHPOINT appuye sur le support de CHOLD et contenant le
  68. CS le champ de flux interpole si intersection et 0. sinon.
  69. CS (type CHPOINT a une composante)
  70. CS CHDEP : champ de deplacement des points interceptes
  71. CS (type CHPOINT a 3 composantes)
  72. CS
  73. CC Remarque : il est necessaire de travailler avec les champs par
  74. CC element du maillage interceptant et non pas avec les
  75. CC coordonnées des points de l'objet maillage car ces
  76. CC champs peuvent avoir subi des changements de repere
  77. CC
  78. CC--------------------------------------------------------------------------
  79. IMPLICIT INTEGER(I-N)
  80. IMPLICIT REAL*8 (A-H,O-Z)
  81. C
  82. -INC CCOPTIO
  83. -INC SMCHPOI
  84. -INC SMCHAML
  85. -INC SMELEME
  86. -INC SMCOORD
  87. -INC CCGEOME
  88. -INC CCREEL
  89. -INC SMTABLE
  90. C
  91. SEGMENT MTRAV1
  92. REAL*8 XPN(NZ1,NBP),YPN(NZ1,NBP),ZPN(NZ1,NBP)
  93. REAL*8 XPN1(NZ1,NBP),YPN1(NZ1,NBP),ZPN1(NZ1,NBP)
  94. REAL*8 CHPAS(NZ1,NBP),CHPAS0(NZ1,NBP),CHFN(NZ1,NBP)
  95. REAL*8 CHDEX(NZ1,NBP),CHDEY(NZ1,NBP),CHDEZ(NZ1,NBP)
  96. LOGICAL INTER(NZ1,NBP)
  97. ENDSEGMENT
  98. C
  99. SEGMENT MTRAV2
  100. REAL*8 COORFAC(NZ2,NEL,3,3),TFN(NZ2,NEL,3)
  101. REAL*8 TXN(NZ2,NEL),TYN(NZ2,NEL),TZN(NZ2,NEL)
  102. ENDSEGMENT
  103. C
  104. POINTEUR CHOLD.MCHPOI,CHNEW.MCHPOI
  105. POINTEUR CHX1.MCHPOI,CHX2.MCHPOI,CHX3.MCHPOI
  106. POINTEUR CHY1.MCHPOI,CHY2.MCHPOI,CHY3.MCHPOI
  107. POINTEUR CHZ1.MCHPOI,CHZ2.MCHPOI,CHZ3.MCHPOI
  108. POINTEUR TAB1.MTABLE
  109. POINTEUR ICHOLD.MELEME
  110. POINTEUR CHCOSX.MCHAML,CHCOSY.MCHAML,CHCOSZ.MCHAML
  111. POINTEUR CHF1.MCHAML,CHF2.MCHAML,CHF3.MCHAML
  112. C
  113. CHARACTER*8 MTYPR
  114. CHARACTER*4 REP,CHARRE
  115. CHARACTER*9 MOTCLE(12)
  116. logical login,logre
  117. C
  118. C LECTURE DES OBJETS
  119. C
  120. CALL LIROBJ('CHPOINT',CHOLD,1,IRETOU)
  121. IF (IERR .NE. 0) RETURN
  122. CALL LIROBJ('CHPOINT',CHNEW,1,IRETOU)
  123. IF (IERR .NE. 0) RETURN
  124. CALL LIRREE(TOL1,1,IRETOU)
  125. IF (IERR .NE. 0) RETURN
  126. CALL LIROBJ('TABLE ',TAB1,1,IRETOU)
  127. IF (IERR .NE. 0) RETURN
  128. C
  129. C Dimensionnement des tableaux du segment MTRAV1
  130. C
  131. MCHPOI=CHOLD
  132. SEGACT MCHPOI
  133. NZ1=IPCHP(/1)
  134. DO 50 I=1,IPCHP(/1)
  135. MSOUPO=IPCHP(I)
  136. SEGACT MSOUPO
  137. MELEME=IGEOC
  138. SEGACT MELEME
  139. IF (I .EQ. 1) NBP=NUM(/2)
  140. IF (NUM(/2) .GT. NBP) NBP=NUM(/2)
  141. SEGDES MELEME
  142. SEGDES MSOUPO
  143. 50 CONTINUE
  144. SEGINI MTRAV1
  145. C
  146. C
  147. C EXTRACTION DES COORDONNEES DES POINTS Pn et Pn+1 a partir des CHPOINT
  148. C CHOLD et CHNEW
  149. C
  150. DO 100 I=1,IPCHP(/1)
  151. MSOUPO=IPCHP(I)
  152. SEGACT MSOUPO
  153. ICHOLD=IGEOC
  154. MPOVAL=IPOVAL
  155. SEGACT MPOVAL
  156. DO 200 J=1,NOCOMP(/2)
  157. IF (NOCOMP(J).EQ. 'X ')then
  158. do 331 k=1,vpocha(/1)
  159. XPN(I,K)=VPOCHA(K,J)
  160. 331 continue
  161. elseif(NOCOMP(J).EQ. 'Y ') then
  162. do 332 k=1,vpocha(/1)
  163. YPN(I,K)=VPOCHA(K,J)
  164. 332 continue
  165. elseif(NOCOMP(J).EQ. 'Z ')then
  166. do 333 k=1,vpocha(/1)
  167. ZPN(I,K)=VPOCHA(K,J)
  168. 333 continue
  169. endif
  170. 200 CONTINUE
  171. SEGDES MPOVAL
  172. SEGDES MELEME
  173. SEGDES MSOUPO
  174. 100 CONTINUE
  175. SEGDES MCHPOI
  176. C
  177. MCHPOI=CHNEW
  178. SEGACT MCHPOI
  179. DO 110 I=1,IPCHP(/1)
  180. MSOUPO=IPCHP(I)
  181. SEGACT MSOUPO
  182. MPOVAL=IPOVAL
  183. SEGACT MPOVAL
  184. DO 210 J=1,NOCOMP(/2)
  185. IF (NOCOMP(J).EQ. 'X ')then
  186. DO 310 K=1,VPOCHA(/1)
  187. XPN1(I,K)=VPOCHA(K,J)
  188. 310 CONTINUE
  189. ELSEIF (NOCOMP(J).EQ. 'Y ')then
  190. DO 311 K=1,VPOCHA(/1)
  191. YPN1(I,K)=VPOCHA(K,J)
  192. 311 CONTINUE
  193. ELSEIF (NOCOMP(J).EQ. 'Z ')then
  194. DO 312 K=1,VPOCHA(/1)
  195. ZPN1(I,K)=VPOCHA(K,J)
  196. 312 CONTINUE
  197. ENDIF
  198. 210 CONTINUE
  199. SEGDES MPOVAL
  200. SEGDES MSOUPO
  201. 110 CONTINUE
  202. SEGDES MCHPOI
  203. C
  204. MOTCLE(1) = '<COSX'
  205. MOTCLE(2) = '<COSY'
  206. MOTCLE(3) = '<COSZ'
  207. MOTCLE(4) = '<CHAMX1 '
  208. MOTCLE(5) = '<CHAMY1 '
  209. MOTCLE(6) = '<CHAMZ1 '
  210. MOTCLE(7) = '<CHAMX2 '
  211. MOTCLE(8) = '<CHAMY2 '
  212. MOTCLE(9) = '<CHAMZ2 '
  213. MOTCLE(10) = '<CHAMX3 '
  214. MOTCLE(11) = '<CHAMY3 '
  215. MOTCLE(12) = '<CHAMZ3 '
  216. C
  217. SEGACT TAB1
  218. CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(1),LOGIN,IOBIN,
  219. . 'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHCOSX)
  220. CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(2),LOGIN,IOBIN,
  221. . 'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHCOSY)
  222. CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(3),LOGIN,IOBIN,
  223. . 'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHCOSZ)
  224. C
  225. MCHELM=CHCOSX
  226. SEGACT MCHELM
  227. C
  228. C Dimensionnement des tableaux du segment MTRAV2
  229. C
  230. NZ2 = ICHAML(/1)
  231. DO 60 I=1,ICHAML(/1)
  232. MCHAML=ICHAML(I)
  233. SEGACT MCHAML
  234. DO 70 IC=1,IELVAL(/1)
  235. IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN
  236. MELVAL=IELVAL(IC)
  237. SEGACT MELVAL
  238. IF (I .EQ. 1) NEL=VELCHE(/2)
  239. IF (VELCHE(/2) .GT. NEL) NEL=VELCHE(/2)
  240. SEGDES MELVAL
  241. ENDIF
  242. 70 CONTINUE
  243. SEGDES MCHAML
  244. 60 CONTINUE
  245. SEGINI MTRAV2
  246. C
  247. C Extraction des trois cosinus directeurs (CHAMELEM) a partir de TAB1
  248. C Les elements du maillage associe sont ici des POI1
  249. C
  250. DO 120 I=1,ICHAML(/1)
  251. MCHAML=ICHAML(I)
  252. SEGACT MCHAML
  253. DO 220 IC=1,IELVAL(/1)
  254. IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN
  255. MELVAL=IELVAL(IC)
  256. SEGACT MELVAL
  257. DO 320 IEL=1,VELCHE(/2)
  258. TXN(I,IEL) = VELCHE(1,IEL)
  259. 320 CONTINUE
  260. SEGDES MELVAL
  261. ENDIF
  262. 220 CONTINUE
  263. SEGDES MCHAML
  264. 120 CONTINUE
  265. SEGDES MCHELM
  266. C
  267. MCHELM=CHCOSY
  268. SEGACT MCHELM
  269. DO 130 I=1,ICHAML(/1)
  270. MCHAML=ICHAML(I)
  271. SEGACT MCHAML
  272. DO 230 IC=1,IELVAL(/1)
  273. IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN
  274. MELVAL=IELVAL(IC)
  275. SEGACT MELVAL
  276. DO 330 IEL=1,VELCHE(/2)
  277. TYN(I,IEL) = VELCHE(1,IEL)
  278. 330 CONTINUE
  279. SEGDES MELVAL
  280. ENDIF
  281. 230 CONTINUE
  282. SEGDES MCHAML
  283. 130 CONTINUE
  284. SEGDES MCHELM
  285. C
  286. MCHELM=CHCOSZ
  287. SEGACT MCHELM
  288. DO 140 I=1,ICHAML(/1)
  289. MCHAML=ICHAML(I)
  290. SEGACT MCHAML
  291. DO 240 IC=1,IELVAL(/1)
  292. IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN
  293. MELVAL=IELVAL(IC)
  294. SEGACT MELVAL
  295. DO 340 IEL=1,VELCHE(/2)
  296. TZN(I,IEL) = VELCHE(1,IEL)
  297. 340 CONTINUE
  298. SEGDES MELVAL
  299. ENDIF
  300. 240 CONTINUE
  301. SEGDES MCHAML
  302. 140 CONTINUE
  303. SEGDES MCHELM
  304. C
  305. C Extraction des coordonnees des 3 points de chaque facette
  306. C
  307. CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(4),LOGIN,
  308. . IOBIN,'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHX1)
  309. CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(5),LOGIN,
  310. . IOBIN,'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHY1)
  311. CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(6),LOGIN,
  312. . IOBIN,'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHZ1)
  313. C
  314. MCHELM=CHX1
  315. SEGACT MCHELM
  316. DO 141 I=1,ICHAML(/1)
  317. MCHAML=ICHAML(I)
  318. SEGACT MCHAML
  319. DO 241 IC=1,IELVAL(/1)
  320. IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN
  321. MELVAL=IELVAL(IC)
  322. SEGACT MELVAL
  323. DO 341 IEL=1,VELCHE(/2)
  324. COORFAC(I,IEL,1,1) = VELCHE(1,IEL)
  325. 341 CONTINUE
  326. SEGDES MELVAL
  327. ENDIF
  328. 241 CONTINUE
  329. SEGDES MCHAML
  330. 141 CONTINUE
  331. SEGDES MCHELM
  332. C
  333. MCHELM=CHY1
  334. SEGACT MCHELM
  335. DO 142 I=1,ICHAML(/1)
  336. MCHAML=ICHAML(I)
  337. SEGACT MCHAML
  338. DO 242 IC=1,IELVAL(/1)
  339. IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN
  340. MELVAL=IELVAL(IC)
  341. SEGACT MELVAL
  342. DO 342 IEL=1,VELCHE(/2)
  343. COORFAC(I,IEL,1,2) = VELCHE(1,IEL)
  344. 342 CONTINUE
  345. SEGDES MELVAL
  346. ENDIF
  347. 242 CONTINUE
  348. SEGDES MCHAML
  349. 142 CONTINUE
  350. SEGDES MCHELM
  351. C
  352. MCHELM=CHZ1
  353. SEGACT MCHELM
  354. DO 143 I=1,ICHAML(/1)
  355. MCHAML=ICHAML(I)
  356. SEGACT MCHAML
  357. DO 243 IC=1,IELVAL(/1)
  358. IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN
  359. MELVAL=IELVAL(IC)
  360. SEGACT MELVAL
  361. DO 343 IEL=1,VELCHE(/2)
  362. COORFAC(I,IEL,1,3) = VELCHE(1,IEL)
  363. 343 CONTINUE
  364. SEGDES MELVAL
  365. ENDIF
  366. 243 CONTINUE
  367. SEGDES MCHAML
  368. 143 CONTINUE
  369. SEGDES MCHELM
  370. C
  371. CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(7),LOGIN,
  372. . IOBIN,'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHX2)
  373. CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(8),LOGIN,
  374. . IOBIN,'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHY2)
  375. CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(9),LOGIN,
  376. . IOBIN,'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHZ2)
  377. C
  378. MCHELM=CHX2
  379. SEGACT MCHELM
  380. DO 144 I=1,ICHAML(/1)
  381. MCHAML=ICHAML(I)
  382. SEGACT MCHAML
  383. DO 244 IC=1,IELVAL(/1)
  384. IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN
  385. MELVAL=IELVAL(IC)
  386. SEGACT MELVAL
  387. DO 344 IEL=1,VELCHE(/2)
  388. COORFAC(I,IEL,2,1) = VELCHE(1,IEL)
  389. 344 CONTINUE
  390. SEGDES MELVAL
  391. ENDIF
  392. 244 CONTINUE
  393. SEGDES MCHAML
  394. 144 CONTINUE
  395. SEGDES MCHELM
  396. C
  397. MCHELM=CHY2
  398. SEGACT MCHELM
  399. DO 145 I=1,ICHAML(/1)
  400. MCHAML=ICHAML(I)
  401. SEGACT MCHAML
  402. DO 245 IC=1,IELVAL(/1)
  403. IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN
  404. MELVAL=IELVAL(IC)
  405. SEGACT MELVAL
  406. DO 345 IEL=1,VELCHE(/2)
  407. COORFAC(I,IEL,2,2) = VELCHE(1,IEL)
  408. 345 CONTINUE
  409. SEGDES MELVAL
  410. ENDIF
  411. 245 CONTINUE
  412. SEGDES MCHAML
  413. 145 CONTINUE
  414. SEGDES MCHELM
  415. C
  416. MCHELM=CHZ2
  417. SEGACT MCHELM
  418. DO 146 I=1,ICHAML(/1)
  419. MCHAML=ICHAML(I)
  420. SEGACT MCHAML
  421. DO 246 IC=1,IELVAL(/1)
  422. IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN
  423. MELVAL=IELVAL(IC)
  424. SEGACT MELVAL
  425. DO 346 IEL=1,VELCHE(/2)
  426. COORFAC(I,IEL,2,3) = VELCHE(1,IEL)
  427. 346 CONTINUE
  428. SEGDES MELVAL
  429. ENDIF
  430. 246 CONTINUE
  431. SEGDES MCHAML
  432. 146 CONTINUE
  433. SEGDES MCHELM
  434. C
  435. CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(10),LOGIN,
  436. . IOBIN,'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHX3)
  437. CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(11),LOGIN,
  438. . IOBIN,'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHY3)
  439. CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(12),LOGIN,
  440. . IOBIN,'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHZ3)
  441. C
  442. MCHELM=CHX3
  443. SEGACT MCHELM
  444. DO 147 I=1,ICHAML(/1)
  445. MCHAML=ICHAML(I)
  446. SEGACT MCHAML
  447. DO 247 IC=1,IELVAL(/1)
  448. IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN
  449. MELVAL=IELVAL(IC)
  450. SEGACT MELVAL
  451. DO 347 IEL=1,VELCHE(/2)
  452. COORFAC(I,IEL,3,1) = VELCHE(1,IEL)
  453. 347 CONTINUE
  454. SEGDES MELVAL
  455. ENDIF
  456. 247 CONTINUE
  457. SEGDES MCHAML
  458. 147 CONTINUE
  459. SEGDES MCHELM
  460. C
  461. MCHELM=CHY3
  462. SEGACT MCHELM
  463. DO 148 I=1,ICHAML(/1)
  464. MCHAML=ICHAML(I)
  465. SEGACT MCHAML
  466. DO 248 IC=1,IELVAL(/1)
  467. IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN
  468. MELVAL=IELVAL(IC)
  469. SEGACT MELVAL
  470. DO 348 IEL=1,VELCHE(/2)
  471. COORFAC(I,IEL,3,2) = VELCHE(1,IEL)
  472. 348 CONTINUE
  473. SEGDES MELVAL
  474. ENDIF
  475. 248 CONTINUE
  476. SEGDES MCHAML
  477. 148 CONTINUE
  478. SEGDES MCHELM
  479. C
  480. MCHELM=CHZ3
  481. SEGACT MCHELM
  482. DO 149 I=1,ICHAML(/1)
  483. MCHAML=ICHAML(I)
  484. SEGACT MCHAML
  485. DO 249 IC=1,IELVAL(/1)
  486. IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN
  487. MELVAL=IELVAL(IC)
  488. SEGACT MELVAL
  489. DO 349 IEL=1,VELCHE(/2)
  490. COORFAC(I,IEL,3,3) = VELCHE(1,IEL)
  491. 349 CONTINUE
  492. SEGDES MELVAL
  493. ENDIF
  494. 249 CONTINUE
  495. SEGDES MCHAML
  496. 149 CONTINUE
  497. SEGDES MCHELM
  498. C
  499. C Lecture des flux
  500. C
  501. MTYPR = ' '
  502. CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,'<CHAMF1',LOGIN,
  503. . IOBIN,MTYPR,IVALRE,XVALRE,CHARRE,LOGRE,CHF1)
  504. IF (MTYPR .EQ. 'MCHAML ') THEN
  505. MCHELM=CHF1
  506. SEGACT MCHELM
  507. DO 150 I=1,ICHAML(/1)
  508. MCHAML=ICHAML(I)
  509. SEGACT MCHAML
  510. DO 250 IC=1,IELVAL(/1)
  511. IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN
  512. MELVAL=IELVAL(IC)
  513. SEGACT MELVAL
  514. DO 350 IEL=1,VELCHE(/2)
  515. TFN(I,IEL,1) = VELCHE(1,IEL)
  516. 350 CONTINUE
  517. SEGDES MELVAL
  518. ENDIF
  519. 250 CONTINUE
  520. SEGDES MCHAML
  521. 150 CONTINUE
  522. SEGDES MCHELM
  523. ENDIF
  524. C
  525. MTYPR = ' '
  526. CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,'<CHAMF2',LOGIN,
  527. . IOBIN,MTYPR,IVALRE,XVALRE,CHARRE,LOGRE,CHF2)
  528. IF (MTYPR .EQ. 'MCHAML ') THEN
  529. MCHELM=CHF2
  530. SEGACT MCHELM
  531. DO 151 I=1,ICHAML(/1)
  532. MCHAML=ICHAML(I)
  533. SEGACT MCHAML
  534. DO 251 IC=1,IELVAL(/1)
  535. IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN
  536. MELVAL=IELVAL(IC)
  537. SEGACT MELVAL
  538. DO 351 IEL=1,VELCHE(/2)
  539. TFN(I,IEL,2) = VELCHE(1,IEL)
  540. 351 CONTINUE
  541. SEGDES MELVAL
  542. ENDIF
  543. 251 CONTINUE
  544. SEGDES MCHAML
  545. 151 CONTINUE
  546. SEGDES MCHELM
  547. ENDIF
  548. C
  549. MTYPR = ' '
  550. CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,'<CHAMF3',LOGIN,
  551. . IOBIN,MTYPR,IVALRE,XVALRE,CHARRE,LOGRE,CHF3)
  552. C
  553. IF (MTYPR .EQ. 'MCHAML ') THEN
  554. MCHELM=CHF3
  555. SEGACT MCHELM
  556. DO 152 I=1,ICHAML(/1)
  557. MCHAML=ICHAML(I)
  558. SEGACT MCHAML
  559. DO 252 IC=1,IELVAL(/1)
  560. IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN
  561. MELVAL=IELVAL(IC)
  562. SEGACT MELVAL
  563. DO 352 IEL=1,VELCHE(/2)
  564. TFN(I,IEL,3) = VELCHE(1,IEL)
  565. 352 CONTINUE
  566. SEGDES MELVAL
  567. ENDIF
  568. 252 CONTINUE
  569. SEGDES MCHAML
  570. 152 CONTINUE
  571. SEGDES MCHELM
  572. ENDIF
  573. C
  574. SEGDES TAB1
  575. C
  576. C Initialisation du tableau des indicateurs d'interception
  577. C
  578. DO 302 I=1,NZ1
  579. DO 301 K=1,NBP
  580. INTER(I,K)=.FALSE.
  581. 301 CONTINUE
  582. 302 CONTINUE
  583. C
  584. C Boucle sur les facettes du maillage OMBRANT
  585. C
  586. MCHELM=CHX1
  587. SEGACT MCHELM
  588. DO 400 I=1,ICHAML(/1)
  589. MCHAML=ICHAML(I)
  590. SEGACT MCHAML
  591. DO 450 IC=1,IELVAL(/1)
  592. IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN
  593. MELVAL=IELVAL(IC)
  594. SEGACT MELVAL
  595. DO 500 J=1,VELCHE(/2)
  596. XA1 = COORFAC(I,J,1,1)
  597. YA1 = COORFAC(I,J,1,2)
  598. ZA1 = COORFAC(I,J,1,3)
  599. C
  600. XB1 = COORFAC(I,J,2,1)
  601. YB1 = COORFAC(I,J,2,2)
  602. ZB1 = COORFAC(I,J,2,3)
  603. C
  604. XC1 = COORFAC(I,J,3,1)
  605. YC1 = COORFAC(I,J,3,2)
  606. ZC1 = COORFAC(I,J,3,3)
  607. C
  608. C Boucle sur les sous-zones du maillage OMBRE
  609. C
  610. DO 550 IZ=1,NZ1
  611. C
  612. C Boucle sur les lignes de champ (ou sur les elements POI1 de OMBRE)
  613. C
  614. DO 600 K=1,NBP
  615. IF (.NOT. INTER(IZ,K)) THEN
  616. C
  617. C Produits scalaires
  618. C
  619. PS1 = ((XPN(IZ,K)-XA1)*TXN(I,J)) +
  620. . ((YPN(IZ,K)-YA1)*TYN(I,J)) +
  621. . ((ZPN(IZ,K)-ZA1)*TZN(I,J))
  622. PS2 = ((XPN1(IZ,K)-XA1)*TXN(I,J)) +
  623. . ((YPN1(IZ,K)-YA1)*TYN(I,J)) +
  624. . ((ZPN1(IZ,K)-ZA1)*TZN(I,J))
  625. C -> -->
  626. C Calcul de PnPn+1 :
  627. C
  628. DEX = XPN1(IZ,K) - XPN(IZ,K)
  629. DEY = YPN1(IZ,K) - YPN(IZ,K)
  630. DEZ = ZPN1(IZ,K) - ZPN(IZ,K)
  631. C
  632. C calcul de la distance de connection par defaut
  633. C
  634. CHPAS0(IZ,K) = (DEX*DEX + DEY*DEY + DEZ*DEZ)**.5
  635. C
  636. C Test d'intersection avec le plan de la facette
  637. C
  638. IF ( (PS1*PS2 .LT. (-1*TOL1*TOL1))
  639. . .OR. (PS2 .EQ. 0.) ) THEN
  640. C
  641. C -> --> ->
  642. C Calcul de AD1 = PnPn+1 . N :
  643. C
  644. AD1 = DEX*TXN(I,J) + DEY*TYN(I,J) + DEZ*TZN(I,J)
  645. C
  646. C Test de detection des lignes de champ paralleles a la facette
  647. C
  648. IF (ABS(AD1) .GT. TOL1) THEN
  649. C
  650. C
  651. C Calcul des points d'intersection M entre les lignes de champ et
  652. C le plan de la facette
  653. C
  654. XM = ( (XA1*DEX*TXN(I,J)) -
  655. . ((((YPN(IZ,K)-YA1)*DEX)-
  656. . (XPN(IZ,K)*DEY))*TYN(I,J)) -
  657. . ((((ZPN(IZ,K)-ZA1)*DEX)-
  658. . (XPN(IZ,K)*DEZ))*TZN(I,J)) ) / AD1
  659. C
  660. YM = ( (YA1*DEY*TYN(I,J)) -
  661. . ((((ZPN(IZ,K)-ZA1)*DEY)-
  662. . (YPN(IZ,K)*DEZ))*TZN(I,J)) -
  663. . ((((XPN(IZ,K)-XA1)*DEY)-
  664. . (YPN(IZ,K)*DEX))*TXN(I,J)) ) / AD1
  665. C
  666. ZM = ( (ZA1*DEZ*TZN(I,J)) -
  667. . ((((XPN(IZ,K)-XA1)*DEZ)-
  668. . (ZPN(IZ,K)*DEX))*TXN(I,J)) -
  669. . ((((YPN(IZ,K)-YA1)*DEZ)-
  670. . (ZPN(IZ,K)*DEY))*TYN(I,J)) ) / AD1
  671. C
  672. C Calcul des vecteurs AM, BM, CM
  673. C
  674. XAM = XM - XA1
  675. XBM = XM - XB1
  676. XCM = XM - XC1
  677. C
  678. C
  679. YAM = YM - YA1
  680. YBM = YM - YB1
  681. YCM = YM - YC1
  682. C
  683. ZAM = ZM - ZA1
  684. ZBM = ZM - ZB1
  685. ZCM = ZM - ZC1
  686. C
  687. C Denominateurs
  688. C
  689. DX = (YCM*ZBM)-(ZCM*YBM)+(ZAM*YBM)-
  690. . (ZAM*YCM)-(YAM*ZBM)+(YAM*ZCM)
  691. C
  692. DY = (ZCM*XBM)-(XCM*ZBM)+(XAM*ZBM)-
  693. . (XAM*ZCM)-(ZAM*XBM)+(ZAM*XCM)
  694. C
  695. DZ = (YCM*XBM)-(XCM*YBM)+(XAM*YBM)-
  696. . (XAM*YCM)-(YAM*XBM)+(YAM*XCM)
  697. C
  698. IF (ABS(DZ) .GT. TOL1) THEN
  699. D1 = DZ
  700. A1 = YCM*XBM-XCM*YBM
  701. B1 = YAM*XCM-XAM*YCM
  702. C1 = YBM*XAM-XBM*YAM
  703. ELSEIF (ABS(DY) .GT. TOL1) THEN
  704. D1 = DY
  705. A1 = ZCM*XBM-XCM*ZBM
  706. B1 = ZAM*XCM-XAM*ZCM
  707. C1 = ZBM*XAM-XBM*ZAM
  708. ELSE
  709. D1 = DX
  710. A1 = YCM*ZBM-ZCM*YBM
  711. B1 = YAM*ZCM-ZAM*YCM
  712. C1 = YBM*ZAM-ZBM*YAM
  713. ENDIF
  714. C
  715. C Coordonnees barycentriques
  716. C
  717. ALPHA = A1 / D1
  718. BETA = B1 / D1
  719. GAMMA = C1 / D1
  720. C
  721. IF ( (ALPHA .GE. 0.) .AND.
  722. . (BETA .GE. 0.) .AND.
  723. . (GAMMA .GE. 0.) ) THEN
  724. C
  725. INTER(IZ,K)=.TRUE.
  726. C
  727. C
  728. C Calcul du Flux Normalise
  729. C
  730. CHFN(IZ,K) = TFN(I,J,1)*ALPHA +
  731. . TFN(I,J,2)*BETA +
  732. . TFN(I,J,3)*GAMMA
  733. C
  734. C Calcul des champs de deplacement :
  735. C
  736. CHDEX(IZ,K) = XPN(IZ,K)-XM
  737. CHDEY(IZ,K) = YPN(IZ,K)-YM
  738. CHDEZ(IZ,K) = ZPN(IZ,K)-ZM
  739.  
  740. C
  741. C Calcul de d(Pn,M) :
  742. C
  743. CHPAS(IZ,K) = ((XPN(IZ,K)-XM)**2. +
  744. . (YPN(IZ,K)-YM)**2. + (ZPN(IZ,K)-ZM)**2.)**.5
  745. ENDIF
  746. ENDIF
  747. ENDIF
  748. ENDIF
  749. 600 CONTINUE
  750. 550 CONTINUE
  751. 500 CONTINUE
  752. SEGDES MELVAL
  753. ENDIF
  754. 450 CONTINUE
  755. SEGDES MCHAML
  756. 400 CONTINUE
  757. SEGDES MCHELM
  758. C
  759. C--------------------------------------------------------
  760. C
  761. C Creation du maillage MINTER des points d'intersection
  762. C
  763. NBNN = 1
  764. NBELEM = NBP
  765. NBSOUS = 0
  766. NBREF = 0
  767. SEGINI MELEME
  768. MINTER = MELEME
  769. ITYPEL = 1
  770. C
  771. C Construction de MINTER
  772. C
  773. IPT1 = ICHOLD
  774. SEGACT IPT1
  775. NINTER = 0
  776. DO 701 I=1,NZ1
  777. DO 700 K=1,NBP
  778. IF (INTER(I,K)) THEN
  779. NINTER = NINTER+1
  780. NUM(1,NINTER) = IPT1.NUM(1,K)
  781. ENDIF
  782. 700 CONTINUE
  783. 701 CONTINUE
  784. NBELEM = NINTER
  785. SEGADJ MELEME
  786. SEGDES MELEME,IPT1
  787. C--------------------------------------------------------
  788. C
  789. C Creation du CHPOINT CHDIST
  790. C
  791. C segment MCHPOI
  792. NAT = 1
  793. NSOUPO = NZ1
  794. SEGINI MCHPOI
  795. ICHDIS = MCHPOI
  796. IFOPOI = 2
  797. JATTRI(1) = 2
  798. C segment MSOUPO
  799. NC = 1
  800. DO 901 I=1,NZ1
  801. SEGINI MSOUPO
  802. IPCHP(I)=MSOUPO
  803. NOCOMP(1)= 'SCAL'
  804. C segment MELEME : maillage associe a CHDIST
  805. NBNN = 1
  806. NBELEM = NBP
  807. NBSOUS = 0
  808. NBREF = 0
  809. C
  810. C LE CHAMPOINT CHDIST S'APPUIE SUR LE MEME MAILLAGE QUE CHOLD
  811. C
  812. IGEOC=ICHOLD
  813. C
  814. C Construction de MPOVAL
  815. C
  816. N = NBP
  817. SEGINI MPOVAL
  818. IPOVAL=MPOVAL
  819. C
  820. C On met la valeur de la distance de connection dans le chpoint CHDIST
  821. C Ce point n'existera plus dans le prochain maillage MINTER
  822. C
  823. DO 900 K=1,NBP
  824. IF (INTER(I,K)) THEN
  825. VPOCHA(K,1)=CHPAS(I,K)
  826. ELSE
  827. VPOCHA(K,1)=CHPAS0(I,K)
  828. ENDIF
  829. 900 CONTINUE
  830. C
  831. SEGDES MPOVAL
  832. SEGDES MSOUPO
  833. 901 CONTINUE
  834. SEGDES MCHPOI
  835. C
  836. C--------------------------------------------------------
  837. C
  838. C Creation du CHPOINT CHFN
  839. C
  840. C segment MCHPOI
  841. NAT = 1
  842. NSOUPO = NZ1
  843. SEGINI MCHPOI
  844. ICHFN = MCHPOI
  845. IFOPOI = 2
  846. JATTRI(1)=2
  847. C segment MSOUPO
  848. NC = 1
  849. DO 911 I=1,NZ1
  850. SEGINI MSOUPO
  851. IPCHP(I)=MSOUPO
  852. NOCOMP(1)= 'SCAL'
  853. C segment MELEME : maillage associe a CHDIST
  854. NBNN = 1
  855. NBELEM = NBP
  856. NBSOUS = 0
  857. NBREF = 0
  858. C
  859. C LE CHAMPOINT CHFN S'APPUIE SUR LE MEME MAILLAGE QUE CHOLD
  860. C
  861. IGEOC=ICHOLD
  862. C
  863. C Construction de MPOVAL
  864. C
  865. N = NBP
  866. SEGINI MPOVAL
  867. IPOVAL=MPOVAL
  868. C
  869. C On met la valeur de la distance de connection dans le chpoint CHDIST
  870. C Ce point n'existera plus dans le prochain maillage MINTER
  871. C
  872. DO 910 K=1,NBP
  873. IF (INTER(I,K)) THEN
  874. VPOCHA(K,1)=CHFN(I,K)
  875. ELSE
  876. VPOCHA(K,1)=0.
  877. ENDIF
  878. 910 CONTINUE
  879. C
  880. C
  881. C Desactivation des segments
  882. C
  883. SEGDES MPOVAL
  884. SEGDES MSOUPO
  885. 911 CONTINUE
  886. SEGDES MCHPOI
  887. C--------------------------------------------------------
  888. C
  889. C Creation du CHPOINT CHDEP
  890. C
  891. C segment MCHPOI
  892. NAT = 1
  893. NSOUPO = 1
  894. SEGINI MCHPOI
  895. ICHDEP = MCHPOI
  896. IFOPOI = 2
  897. JATTRI(1) = 1
  898. C segment MSOUPO
  899. NC = 3
  900. SEGINI MSOUPO
  901. IPCHP(1)=MSOUPO
  902. NOCOMP(1)= 'UX '
  903. NOCOMP(2)= 'UY '
  904. NOCOMP(3)= 'UZ '
  905. C segment MELEME : maillage associe a CHDIST
  906. NBNN = 1
  907. NBELEM = NBP
  908. NBSOUS = 0
  909. NBREF = 0
  910. C
  911. C LE CHAMPOINT CHDEP S'APPUIE SUR LE MEME MAILLAGE QUE MINTER
  912. C
  913. IGEOC=MINTER
  914. C
  915. C Construction de MPOVAL
  916. C
  917. N = NINTER
  918. SEGINI MPOVAL
  919. IPOVAL=MPOVAL
  920. C
  921. NINTER = 0
  922. C
  923. C On met la valeur du champ de deplacement dans le chpoint CHDEP
  924. C
  925. DO 921 I=1,NZ1
  926. DO 920 K=1,NBP
  927. IF (INTER(I,K)) THEN
  928. NINTER = NINTER+1
  929. VPOCHA(NINTER,1)= 0. - CHDEX(I,K)
  930. VPOCHA(NINTER,2)= 0. - CHDEY(I,K)
  931. VPOCHA(NINTER,3)= 0. - CHDEZ(I,K)
  932. ENDIF
  933. 920 CONTINUE
  934. 921 CONTINUE
  935. C
  936. C
  937. C Desactivation des segments
  938. C
  939. SEGDES MPOVAL
  940. SEGDES MSOUPO
  941. SEGDES MCHPOI
  942. C--------------------------------------------------------
  943. C
  944. C Ecriture des nouveaux objets en sortie
  945. C
  946. CALL ECROBJ('CHPOINT ',ICHDEP)
  947. CALL ECROBJ('CHPOINT ',ICHFN)
  948. C
  949. CALL ECROBJ('MAILLAGE',MINTER)
  950. C
  951. CALL ECROBJ('CHPOINT ',ICHDIS)
  952. C
  953. SEGSUP MTRAV1
  954. SEGSUP MTRAV2
  955. C
  956. RETURN
  957. END
  958.  
  959.  
  960.  
  961.  
  962.  
  963.  
  964.  
  965.  
  966.  
  967.  

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