Télécharger extrel.eso

Retour à la liste

Numérotation des lignes :

  1. C EXTREL SOURCE CB215821 18/09/11 21:15:16 9913
  2. C
  3. C CE SOUS PROGRAMME A POUR OBJET D'EXTRAIRE D'UN OBJET COMPLEXE
  4. C LE SOUS OBJET FORME DES ELEMENTS DEMANDES
  5. C LA SYNTAXE EN EST :
  6. C ELEM | (TYPE SI PLUSIEURS) | (IEL)
  7. C | (LISTE ENTIERS)
  8. C | CONTENANT POINT (TOUS)
  9. C | APPUYES | (LARGE) OBJ
  10. C | STRICT
  11. C
  12. SUBROUTINE EXTREL(IRR,IFLAG,LIEL)
  13.  
  14. IMPLICIT INTEGER(I-N)
  15. IMPLICIT REAL*8 (A-H,O-Z)
  16.  
  17. -INC CCOPTIO
  18. -INC CCGEOME
  19. -INC CCREEL
  20.  
  21. -INC SMLENTI
  22. -INC SMLMOTS
  23. -INC SMELEME
  24. -INC SMCOORD
  25.  
  26. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  27. SEGMENT ISOM(NBS)
  28.  
  29. PARAMETER (NCLE=6)
  30. CHARACTER*4 MCLE(NCLE),MOTM(9),MOABS(1),MOTAV(2)
  31. CHARACTER*4 MSCLE(3),MCLE2(1)
  32. DIMENSION INBC(10)
  33. DATA MOTAV/'AVEC','SANS'/
  34. DATA MOTM/'MAXI','MINI','SUPE','EGSU',
  35. . 'EGAL','EGIN','INFE','DIFF','COMP'/
  36. DATA MOABS/'ABS '/
  37. DATA MCLE/'CONT','APPU','TYPE','COUL','COMP','ZONE'/
  38. DATA MSCLE/'STRI','LARG','NOVE'/
  39. DATA MCLE2/'TOUS'/
  40.  
  41. C INITIALISATIONS
  42. IRR =0
  43. LIEL=0
  44. IOB =0
  45.  
  46. c LECTURE DU MAILLAGE
  47. CALL LIROBJ('MAILLAGE',MELEME,0,IRETOU)
  48. IF (IERR.NE.0) RETURN
  49. IF (IRETOU.EQ.0) GOTO 5000
  50. *
  51. * EXTRACTION DES ELEMENTS D'UN MAILLAGE
  52. *
  53. SEGACT MELEME
  54.  
  55. NIEL=0
  56. ICPR=0
  57. ISOM=0
  58. c icle2 relatif a l option TOUS, NIEL= nbre d EF trouves
  59. ICLE2=0
  60. c LECTURE DES MOTS-CLE
  61. CALL LIRMOT(NOMS,NOMBR,IDES,0)
  62. IF (IERR.NE.0) RETURN
  63. IF (IDES.NE.0) GOTO 2
  64. CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0)
  65. IF (IERR.NE.0) RETURN
  66. IF (ICOUL.NE.0) GOTO 11
  67. CALL LIRMOT(MCLE,NCLE,IMLU,0)
  68. IF (IERR.NE.0) RETURN
  69. IF (IMLU.NE.0) GOTO 20
  70. C ON N'A PAS LU DE MOT-CLE ON PEUT CONTINUER SI L'OBJET CONTIENT UN
  71. C SEUL TYPE D'ELEMENT
  72. IF (LISOUS(/1).NE.0) THEN
  73. CALL ERREUR(25)
  74. RETURN
  75. ENDIF
  76. IDES = meleme.ITYPEL
  77. 2 CONTINUE
  78. IF (LISOUS(/1).NE.0) GOTO 3
  79. IF (ITYPEL.NE.IDES) THEN
  80. CALL ERREUR(26)
  81. RETURN
  82. ENDIF
  83. GOTO 4
  84. 3 CONTINUE
  85. if (ides.ne.22.and.ides.ne.48) then
  86. DO 5 I=1,LISOUS(/1)
  87. IPT2=LISOUS(I)
  88. SEGACT IPT2
  89. IF(IPT2.ITYPEL.EQ.IDES)GOTO 6
  90. SEGACT IPT2
  91. 5 CONTINUE
  92. CALL ERREUR(26)
  93. SEGACT MELEME
  94. RETURN
  95. else
  96. nbso=0
  97. do 555 I=1,LISOUS(/1)
  98. IPT2=LISOUS(I)
  99. SEGACT IPT2
  100. if (IPT2.ITYPEL.EQ.IDES) then
  101. nbso=nbso+1
  102. if (nbso.gt.10) then
  103. call erreur(279)
  104. return
  105. endif
  106. inbc(nbso)=ipt2
  107. SEGACT ipt2
  108. endif
  109. 555 continue
  110. if (nbso.eq.0) then
  111. call erreur(26)
  112. SEGACT meleme
  113. return
  114. elseif(nbso.eq.1) then
  115. ipt2=inbc(1)
  116. goto 1000
  117. else
  118. nbnn=0
  119. nbelem=0
  120. nbsous=nbso
  121. nbref=0
  122. segini ipt2
  123. do jo =1,nbso
  124. ipt2.lisous(jo)=inbc(jo)
  125. enddo
  126. go to 1000
  127. endif
  128. endif
  129. 6 CONTINUE
  130. SEGACT MELEME
  131. MELEME=IPT2
  132. CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0)
  133. IF (IERR.NE.0) RETURN
  134. IF (ICOUL.NE.0) GOTO 11
  135. 4 CONTINUE
  136. CALL LIRENT(IEL,0,IRETOU)
  137. IF (IERR.NE.0) RETURN
  138. IF (IRETOU.EQ.0) GOTO 50
  139.  
  140. C ECRITURE DU MAILLAGE RESULTATS
  141. 7 CONTINUE
  142. SEGACT MELEME
  143. C qq verif
  144. IF (IEL.LE.0.OR.IEL.GT.NUM(/2)) THEN
  145. CALL ERREUR(262)
  146. RETURN
  147. ENDIF
  148. C creation (ou ajustement du meleme resultat)
  149. NBSOUS =0
  150. NBREF =0
  151. NBNN =NUM(/1)
  152. IF ((ICLE2.EQ.0).OR.(NIEL.EQ.0)) THEN
  153. NBELEM=1
  154. SEGINI,IPT2
  155. ELSE
  156. C BP: pour l instant on suppose qu on a qu 1 seul type d element
  157. NBELEM=NIEL+1
  158. SEGADJ,IPT2
  159. ENDIF
  160. IPT2.ITYPEL=ITYPEL
  161. IPT2.ICOLOR(NBELEM)=ICOLOR(IEL)
  162. DO 8 I=1,NBNN
  163. IPT2.NUM(I,NBELEM)=NUM(I,IEL)
  164. 8 CONTINUE
  165. NIEL=NBELEM
  166. LIEL=IEL
  167. IF (ISOM.NE.0) SEGACT,ISOM
  168. C OPTION 'TOUS' : ON RECOMMENCE
  169. IF (ICLE2.NE.0) THEN
  170. IOB1=IOB
  171. JDEB1=IEL+1
  172. IF(JDEB1.LE.NUM(/2)) GOTO 25
  173. JDEB1=1
  174. IOB1=IOB1+1
  175. IF(IOB1.LE.MAX(1,LISOUS(/1))) GOTO 25
  176. ENDIF
  177. GOTO 1000
  178. C CAR C'EST FINI
  179. 11 CONTINUE
  180. ICOUL=ICOUL-1
  181. C DETERMINATION DES ELEMENTS D'UNE COULEUR DONNEE:ICOUL
  182. C REMPLIR LE TABLEAU DU NOMBRE DES ELEMENTS
  183. DO 12 I=1,10
  184. INBC(I)=0
  185. 12 CONTINUE
  186. ICPT=0
  187. IPT1=MELEME
  188. DO 13 I=1,MAX(1,LISOUS(/1))
  189. IF (LISOUS(/1).NE.0) THEN
  190. IPT1=LISOUS(I)
  191. SEGACT IPT1
  192. ENDIF
  193. ICPT=ICPT+1
  194. DO 15 J=1,IPT1.NUM(/2)
  195. IF(IPT1.ICOLOR(J).EQ.ICOUL) INBC(ICPT)=INBC(ICPT)+1
  196. 15 CONTINUE
  197. IF(LISOUS(/1).NE.0) SEGACT IPT1
  198. 13 CONTINUE
  199. NB=0
  200. DO 17 I=1,10
  201. IF(INBC(I).NE.0) NB=NB+1
  202. 17 CONTINUE
  203. IF (NB.EQ.0) CALL ERREUR(222)
  204. IF (NB.EQ.1) THEN
  205. NBSOUS=0
  206. NBREF=0
  207. IF (LISOUS(/1).NE.0) THEN
  208. DO 18 I=1,10
  209. IF(INBC(I).NE.0) IREP=I
  210. 18 CONTINUE
  211. IPT1=LISOUS(IREP)
  212. SEGACT IPT1
  213. NBNN=IPT1.NUM(/1)
  214. NBELEM=INBC(IREP)
  215. ELSE
  216. NBNN=NUM(/1)
  217. NBELEM=INBC(1)
  218. IPT1=MELEME
  219. ENDIF
  220. SEGINI IPT2
  221. II=0
  222. IPT2.ITYPEL=IPT1.ITYPEL
  223. DO 19 J=1,IPT1.NUM(/2)
  224. IF(IPT1.ICOLOR(J).NE.ICOUL) GOTO 19
  225. II=II+1
  226. IPT2.ICOLOR(II)=ICOUL
  227. DO 93 I=1,NBNN
  228. IPT2.NUM(I,II)=IPT1.NUM(I,J)
  229. 93 CONTINUE
  230. 19 CONTINUE
  231. IF(LISOUS(/1).NE.0) SEGACT IPT1
  232. ELSE
  233. NBSOUS=NB
  234. NBREF=0
  235. NBNN=0
  236. NBELEM=0
  237. SEGINI IPT2
  238. IB=0
  239. DO 90 I=1,10
  240. IF(INBC(I).EQ.0) GOTO 90
  241. IB=IB+1
  242. IPT3=LISOUS(I)
  243. SEGACT IPT3
  244. NBSOUS=0
  245. NBREF=0
  246. NBNN=IPT3.NUM(/1)
  247. NBELEM=INBC(I)
  248. SEGINI IPT4
  249. IPT4.ITYPEL=IPT3.ITYPEL
  250. II=0
  251. DO 91 J=1,IPT3.NUM(/2)
  252. IF(IPT3.ICOLOR(J).NE.ICOUL) GOTO 91
  253. II=II+1
  254. IPT4.ICOLOR(II)=ICOUL
  255. DO 94 K=1,NBNN
  256. IPT4.NUM(K,II)=IPT3.NUM(K,J)
  257. 94 CONTINUE
  258. 91 CONTINUE
  259. SEGACT IPT3
  260. IPT2.LISOUS(IB)=IPT4
  261. SEGACT IPT4
  262. 90 CONTINUE
  263. SEGACT IPT2
  264. ENDIF
  265. SEGACT MELEME
  266. MELEME=IPT2
  267. CALL LIRMOT (NOMS,NOMBR,IDES,0)
  268. IF(IDES.NE.0) GOTO 2
  269. GOTO 4
  270.  
  271. 20 CONTINUE
  272. c ON A LU 'CONT', 'APPU', 'TYPE', 'COUL', 'COMP', ou 'ZONE'
  273. IF(IMLU.NE.1) GOTO 30
  274. C ON A LU CONT : ON VEUT LIROBJ UN POINT
  275. CALL LIROBJ('POINT ',IP,1,IRETOU)
  276. IF(IERR.NE.0) RETURN
  277. SEGACT MCOORD
  278. IREFP=(IP-1)*(IDIM+1)+1
  279. XP=XCOOR(IREFP)
  280. YP=XCOOR(IREFP+1)
  281. ZP=XCOOR(IREFP+2)
  282. IF(IDIM.EQ.2) ZP=0.D0
  283. C BP: cherche t on 'TOUS' les elements qui contiennent ce point ?
  284. ICLE2=0
  285. CALL LIRMOT(MCLE2,1,ICLE2,0)
  286. C sg option noverif
  287. NOVER=0
  288. CALL LIRMOT(MSCLE(3),1,NOVER,0)
  289. C NIEL = nbre d'EF trouvés, IOB1 et JDEB1 = debut de boucles
  290. NIEL =0
  291. IOB1 =1
  292. JDEB1=1
  293. 25 CONTINUE
  294. IPT1=MELEME
  295. C BOUCLE SUR LES EVENTUELS SOUS-OBJETS
  296. DO 22 IOB=IOB1,MAX(1,LISOUS(/1))
  297. IF (LISOUS(/1).NE.0) THEN
  298. IPT1=LISOUS(IOB)
  299. SEGACT IPT1
  300. ENDIF
  301. C 21 CONTINUE
  302. C
  303. cbp2016 : tous les elements doivent avoir toutes leurs faces orientees
  304. cbp2016 dans la meme direction (vers l'interieur)
  305. cbp2016 IA1 = 0
  306. cbp2016 IF(IPT1.ITYPEL.EQ.14.OR.IPT1.ITYPEL.EQ.15)IA1 = 1
  307. cbp2016 IF(IPT1.ITYPEL.EQ.16.OR.IPT1.ITYPEL.EQ.17)IA1 = 7
  308. C
  309. NBNN=IPT1.NUM(/1)
  310. IF(KSURF(IPT1.ITYPEL).NE.0) GOTO 60
  311. C C'EST UNE LIGNE
  312. C Recherche du point le plus proche + élément contenant ce point
  313. IPT5 = IPT1
  314. CALL CHANGE(IPT5,1)
  315. IF (IERR.NE.0) RETURN
  316. CALL ECROBJ('POINT ',IP)
  317. CALL ECRCHA('PROC')
  318. CALL ECROBJ('MAILLAGE',IPT5)
  319. CALL POIEXT
  320. CALL LIROBJ('POINT ',IP1,1,IRETOU)
  321. IF (IERR.NE.0) RETURN
  322. SEGACT IPT1
  323. DO 40 J=1,IPT1.NUM(/2)
  324. DO 41 K=1,NBNN
  325. IF (IPT1.NUM(K,J).EQ.IP1) THEN
  326. GOTO 100
  327. ENDIF
  328. 41 CONTINUE
  329. 40 CONTINUE
  330. GOTO 23
  331.  
  332. 60 IF(KSURF(IPT1.ITYPEL).NE.IPT1.ITYPEL) GOTO 70
  333. C C'EST UNE SURFACE
  334. NBS = NBSOM(IPT1.ITYPEL)
  335. IF (NBS.EQ.0) THEN
  336. C Polygone a N cotes
  337. NBS = IPT1.NUM(/1)
  338. ENDIF
  339. SEGINI ISOM
  340. DO 61 I=1,ISOM(/1)
  341. ISOM(I)=IBSOM(NSPOS(IPT1.ITYPEL)-1+I)
  342. 61 CONTINUE
  343. DO 62 J=JDEB1,IPT1.NUM(/2)
  344. I1=IPT1.NUM(ISOM(1),J)
  345. I2=IPT1.NUM(ISOM(2),J)
  346. I3=IPT1.NUM(ISOM(3),J)
  347. IREF1=(I1-1)*(IDIM+1)
  348. IREF2=(I2-1)*(IDIM+1)
  349. IREF3=(I3-1)*(IDIM+1)
  350. X1=XCOOR(IREF1+1)
  351. X2=XCOOR(IREF2+1)
  352. X3=XCOOR(IREF3+1)
  353. Y1=XCOOR(IREF1+2)
  354. Y2=XCOOR(IREF2+2)
  355. Y3=XCOOR(IREF3+2)
  356. Z1=XCOOR(IREF1+3)
  357. Z2=XCOOR(IREF2+3)
  358. Z3=XCOOR(IREF3+3)
  359. XNORM=(Y2-Y1)*(Z2-Z3)-(Z2-Z1)*(Y2-Y3)
  360. YNORM=(Z2-Z1)*(X2-X3)-(X2-X1)*(Z2-Z3)
  361. ZNORM=(X2-X1)*(Y2-Y3)-(Y2-Y1)*(X2-X3)
  362. IF (IDIM.EQ.2) THEN
  363. XNORM=0.D0
  364. YNORM=0.D0
  365. ENDIF
  366. DNORM=SQRT(XNORM**2+YNORM**2+ZNORM**2)
  367. XNORM=XNORM/DNORM
  368. YNORM=YNORM/DNORM
  369. ZNORM=ZNORM/DNORM
  370. ANG=0.D0
  371. I1=IPT1.NUM(ISOM(ISOM(/1)),J)
  372. IREF1=(I1-1)*(IDIM+1)
  373. XV1=XCOOR(IREF1+1)-XP
  374. YV1=XCOOR(IREF1+2)-YP
  375. ZV1=XCOOR(IREF1+3)-ZP
  376. IF(IDIM.EQ.2) ZV1=0.D0
  377. DO 63 IS=1,ISOM(/1)
  378. I2=IPT1.NUM(ISOM(IS),J)
  379. IREF2=(I2-1)*(IDIM+1)
  380. XV2=XCOOR(IREF2+1)-XP
  381. YV2=XCOOR(IREF2+2)-YP
  382. ZV2=XCOOR(IREF2+3)-ZP
  383. IF(IDIM.EQ.2) ZV2=0.D0
  384. XATA=XNORM*(YV1*ZV2-ZV1*YV2)+YNORM*(ZV1*XV2-XV1*ZV2)+
  385. # ZNORM*(XV1*YV2-YV1*XV2)
  386. YATA=XV1*XV2+YV1*YV2+ZV1*ZV2
  387. IF(XATA.EQ.0.D0.AND.YATA.EQ.0.D0) GOTO 100
  388. IF (IFLAG.EQ.1) THEN
  389. IF(ABS(ABS(ATAN2(XATA,YATA))-XPI).LT.0.0001D0)GO
  390. $ TO 100
  391. ENDIF
  392. ANG=ANG+ATAN2(XATA,YATA)
  393. XV1=XV2
  394. YV1=YV2
  395. ZV1=ZV2
  396. 63 CONTINUE
  397. IF (IFLAG.EQ.1) THEN
  398. IF(ABS(ABS(ANG)-XPI).LT.0.0001D0)GO TO 100
  399. ENDIF
  400. IF(ABS(ANG).GT.XPI) GOTO 100
  401. 62 CONTINUE
  402. SEGSUP ISOM
  403. ISOM=0
  404. GOTO 23
  405.  
  406. 70 CONTINUE
  407. C C'EST UN VOLUME
  408. NBFAC=LTEL(1,IPT1.ITYPEL)
  409. IAD=LTEL(2,IPT1.ITYPEL)-1
  410. IF(NBFAC.EQ.0) GOTO 23
  411. DO 71 J=JDEB1,IPT1.NUM(/2)
  412. XMI=XGRAND
  413. XMA=-XGRAND
  414. YMI=XGRAND
  415. YMA=-XGRAND
  416. ZMI=XGRAND
  417. ZMA=-XGRAND
  418. DO 710 KKI=1,IPT1.NUM(/1)
  419. IA=(IPT1.NUM(KKI,J)-1)*( IDIM+1)
  420. XMI=MIN(XMI,XCOOR(IA+1))
  421. XMA=MAX(XMA,XCOOR(IA+1))
  422. YMI=MIN(YMI,XCOOR(IA+2))
  423. YMA=MAX(YMA,XCOOR(IA+2))
  424. ZMI=MIN(ZMI,XCOOR(IA+3))
  425. ZMA=MAX(ZMA,XCOOR(IA+3))
  426. 710 CONTINUE
  427. XXM=XMA-XMI
  428. YYM=YMA-YMI
  429. ZZM=ZMA-ZMI
  430. IF( XXM.EQ.0.D0.OR.YYM.EQ.0.D0.OR.ZZM.EQ.0.D0) THEN
  431. CALL ERREUR(26)
  432. RETURN
  433. ENDIF
  434. XDE=((XMI-XP)*(XP-XMA))/XXM/XXM
  435. YDE=((YMI-YP)*(YP-YMA))/YYM/YYM
  436. ZDE=((ZMI-ZP)*(ZP-ZMA))/ZZM/ZZM
  437. IF(XDE.LT.-0.001D0.OR.YDE.LT.-0.001D0.OR.ZDE.LT.-0.001D0
  438. $ )GO TO 71
  439. ANG=0.D0
  440. cbp2016 IMULT = 1
  441. DO 72 IFAC=1,NBFAC
  442. cbp2016 IF(IA1.NE.0) IMULT = KSIF(IA1+IFAC-1)
  443. ITYP=LDEL(1,IAD+IFAC)
  444. NPFAC=KDFAC(1,ITYP)
  445. IF (NPFAC.EQ.0) THEN
  446. C Polygone a n cotes
  447. NPFAC = IPT1.NUM(/1)
  448. ENDIF
  449. JAD=LDEL(2,IAD+IFAC)-1
  450. IA=IPT1.NUM(LFAC(JAD+1),J)
  451. IREFA=(IA-1)*(IDIM+1)+1
  452. DO 73 MAUX=3,NPFAC
  453. IB=IPT1.NUM(LFAC(JAD+MAUX-1),J)
  454. IC=IPT1.NUM(LFAC(JAD+MAUX),J)
  455. IREFB=(IB-1)*(IDIM+1)+1
  456. IREFC=(IC-1)*(IDIM+1)+1
  457. CALL ANGSOL(XCOOR(IREFP),XCOOR(IREFA),XCOOR(IREFB)
  458. $ ,XCOOR(IREFC),AN,IFLAG,IFLIG)
  459. IF(IERR .NE. 0) RETURN
  460. IF (IFLAG.EQ.1) THEN
  461. IF(ABS(ABS(AN)-(2.D0*XPI)) .LT. 1D-4) GOTO 100
  462. IF(IFLIG.EQ.1) GOTO 100
  463. ENDIF
  464. cbp2016 ANG=ANG+AN*IMULT
  465. ANG=ANG+AN
  466. 73 CONTINUE
  467. 72 CONTINUE
  468. IF(ABS(ANG) .GT. XPI) GOTO 100
  469. 71 CONTINUE
  470. 23 CONTINUE
  471. IF(LISOUS(/1).NE.0) SEGACT IPT1
  472. JDEB1=1
  473. 22 CONTINUE
  474. C FIN DE BOUCLE SUR LES SOUS-OBJETS MAILLAGE
  475. c option 'TOUS' + on a trouve au moins 1 element => fin heureuse
  476. IF((ICLE2.NE.0).AND.(NIEL.GE.1)) GOTO 1000
  477. c sinon c est qu on rien trouve => erreur si nover=0
  478. IF (NOVER.EQ.1) THEN
  479. CALL MELVID(ilcour,ipt2)
  480. GOTO 1000
  481. ENDIF
  482. SEGACT MELEME
  483. IRR=1
  484. RETURN
  485.  
  486. 100 IF (LISOUS.NE.0) SEGACT MELEME
  487. MELEME=IPT1
  488. IEL=J
  489. GOTO 7
  490.  
  491. 50 CONTINUE
  492. C ON LIT UN OBJET MLENTI
  493. CALL LIROBJ('LISTENTI',MLENTI,0,IRETOU)
  494. IF(IRETOU.EQ.0) GOTO 58
  495. SEGACT MLENTI
  496. NBNN=NUM(/1)
  497. NBELEM=LECT(/1)
  498. NBSOUS=0
  499. NBREF=0
  500. IF(NBELEM.EQ.0) CALL ERREUR(25)
  501. SEGINI IPT2
  502. IPT2.ITYPEL=ITYPEL
  503. DO 51 JJ=1,NBELEM
  504. J=LECT(JJ)
  505. IF(J.LE.0.OR.J.GT.NUM(/2)) CALL ERREUR(36)
  506. IF(IERR.NE.0) GOTO 55
  507. IPT2.ICOLOR(JJ)=ICOLOR(J)
  508. DO 52 I=1,NBNN
  509. IPT2.NUM(I,JJ)=NUM(I,J)
  510. 52 CONTINUE
  511. 51 CONTINUE
  512. SEGACT MLENTI
  513. GOTO 1000
  514. 58 CONTINUE
  515. IPT2=MELEME
  516. GOTO 1001
  517. 55 SEGSUP IPT2
  518. SEGACT MELEME
  519. RETURN
  520. 1000 CONTINUE
  521. SEGACT MELEME
  522. 1001 SEGACT IPT2
  523. CALL ECROBJ('MAILLAGE',IPT2)
  524. RETURN
  525. 30 CONTINUE
  526. IF(IMLU.NE.2) GO TO 330
  527. C ON A LU APPUYE ON LIT UN DEUXIEME OBJET ET ON FAIT EN SORTE QUE
  528. C CE SOIT DES POINTS
  529. C MODIF MAI 1986 ON AUTORISE A LIROBJ UN SEUL POINT
  530. C NOUVELLE OPTION STRICT LARGE
  531. CALL LIRMOT(MSCLE,2,IMSLU,0)
  532. IF(IMSLU.EQ.0) IMSLU=1
  533. CALL LIROBJ('MAILLAGE',IPT1,0,IPLU)
  534. IF (IPLU.EQ.0) THEN
  535. CALL LIROBJ('POINT ',IPT1,1,IRETOU)
  536. IF(IERR.NE.0) RETURN
  537. CALL CRELEM(IPT1)
  538. ELSE
  539. SEGACT IPT1
  540. IPLU=IPT1.ITYPEL
  541. IF(IPLU.NE.1) CALL CHANGE(IPT1,1)
  542. ENDIF
  543. NOVER=0
  544. CALL LIRMOT(MSCLE(3),1,NOVER,0)
  545. SEGINI ICPR
  546. DO 231 I=1,XCOOR(/1)/(IDIM+1)
  547. ICPR(I)=0
  548. 231 CONTINUE
  549. SEGACT IPT1
  550. DO 232 J=1,IPT1.NUM(/2)
  551. ICPR(IPT1.NUM(1,J))=1
  552. 232 CONTINUE
  553. C TEST ET CREATION DU SEGMENT RESULTAT
  554. NBREF=0
  555. NBSOU=LISOUS(/1)
  556. IPT2=MELEME
  557. IF (NBSOU.NE.0) THEN
  558. NBNN=0
  559. NBELEM=0
  560. NBSOUS=NBSOU
  561. SEGINI IPT8
  562. ISO=0
  563. ENDIF
  564. DO 270 ISOUS=1,MAX(1,NBSOU)
  565. IF (NBSOU.NE.0) THEN
  566. IPT2=LISOUS(ISOUS)
  567. SEGACT IPT2
  568. ENDIF
  569. NBNN=IPT2.NUM(/1)
  570. NBELEM=IPT2.NUM(/2)
  571. ICOUNT=0
  572. DO 250 IEL=1,NBELEM
  573. IF (IMSLU.EQ.1) THEN
  574. DO 251 INOEU=1,NBNN
  575. IF(ICPR(IPT2.NUM(INOEU,IEL)).EQ.0) GOTO 250
  576. 251 CONTINUE
  577. ICOUNT=ICOUNT+1
  578. ELSE
  579. DO 252 INOEU=1,NBNN
  580. IF(ICPR(IPT2.NUM(INOEU,IEL)).NE.0) GOTO 253
  581. 252 CONTINUE
  582. GOTO 250
  583. 253 CONTINUE
  584. ICOUNT=ICOUNT+1
  585. ENDIF
  586. 250 CONTINUE
  587. NBSOUS=0
  588. NBREF=0
  589. NBEL=NBELEM
  590. NBELEM=ICOUNT
  591. ICOUNT=1
  592. IF(NBELEM.EQ.0) GOTO 260
  593. SEGINI IPT3
  594. IPT3.ITYPEL=IPT2.ITYPEL
  595. DO 255 IEL=1,NBEL
  596. IF (IMSLU.EQ.1) THEN
  597. DO 256 INOEU=1,NBNN
  598. IF(ICPR(IPT2.NUM(INOEU,IEL)).EQ.0) GOTO 255
  599. IPT3.NUM(INOEU,ICOUNT)=IPT2.NUM(INOEU,IEL)
  600. 256 CONTINUE
  601. IPT3.ICOLOR(ICOUNT)=IPT2.ICOLOR(IEL)
  602. ICOUNT=ICOUNT+1
  603. IF(ICOUNT.GT.NBELEM) GOTO 260
  604. ELSE
  605. IOOK=0
  606. DO 257 INOEU=1,NBNN
  607. IF(ICPR(IPT2.NUM(INOEU,IEL)).NE.0) IOOK=1
  608. IPT3.NUM(INOEU,ICOUNT)=IPT2.NUM(INOEU,IEL)
  609. 257 CONTINUE
  610. IF(IOOK.EQ.0) GOTO 255
  611. IPT3.ICOLOR(ICOUNT)=IPT2.ICOLOR(IEL)
  612. ICOUNT=ICOUNT+1
  613. IF(ICOUNT.GT.NBELEM) GOTO 260
  614. ENDIF
  615. 255 CONTINUE
  616. 260 CONTINUE
  617. IF (NBSOU.EQ.0) THEN
  618. IF (NBELEM.EQ.0) THEN
  619. IF (NOVER.EQ.0) THEN
  620. GOTO 9988
  621. ELSE
  622. call melvid(ILCOUR,IPT4)
  623. CALL ECROBJ('MAILLAGE',IPT4)
  624. RETURN
  625. ENDIF
  626. ENDIF
  627. GOTO 280
  628. ENDIF
  629. IF (NBELEM.NE.0) THEN
  630. IPT8.LISOUS(ISOUS)=IPT3
  631. ISO=ISO+1
  632. SEGACT IPT3
  633. ENDIF
  634. 270 CONTINUE
  635. IF (ISO.EQ.1) THEN
  636. SEGSUP IPT8
  637. GOTO 280
  638. ENDIF
  639. IPT3=IPT8
  640. IF(ISO.EQ.NBSOU) GOTO 280
  641. NBSOUS=ISO
  642. NBREF=0
  643. NBNN=0
  644. NBELEM=0
  645. SEGINI IPT4
  646. ISO=0
  647. DO 275 IS=1,NBSOU
  648. IF(IPT3.LISOUS(IS).EQ.0) GOTO 275
  649. ISO=ISO+1
  650. IPT4.LISOUS(ISO)=IPT3.LISOUS(IS)
  651. 275 CONTINUE
  652. IF (ISO.EQ.0) THEN
  653. IF (NOVER.EQ.0) THEN
  654. GOTO 9988
  655. ELSE
  656. CALL melvid(ILCOUR,IPT4)
  657. CALL ECROBJ('MAILLAGE',IPT4)
  658. RETURN
  659. ENDIF
  660. ENDIF
  661. SEGSUP IPT3
  662. IPT3=IPT4
  663. 280 CONTINUE
  664. SEGACT IPT3
  665. CALL ECROBJ('MAILLAGE',IPT3)
  666. SEGACT IPT1
  667. SEGSUP ICPR
  668. RETURN
  669. 330 CONTINUE
  670. IF(IMLU.NE.3) GO TO 340
  671. *
  672. * OPTION 'TYPE' SELON PROPOSITION ISPRA
  673. *
  674. I1 = meleme.LISOUS(/1)
  675. JGN=4
  676. JGM=MAX(1,I1)
  677. SEGINI MLMOTS
  678. IF (I1.EQ.0) THEN
  679. MOTS(1)=NOMS(ITYPEL)
  680. ELSE
  681. DO 33 I=1,I1
  682. IPT2=LISOUS(I)
  683. SEGACT IPT2
  684. IDES=IPT2.ITYPEL
  685. MOTS(I)=NOMS(IDES)
  686. SEGACT IPT2
  687. 33 CONTINUE
  688. ENDIF
  689. SEGACT MLMOTS
  690. SEGACT,MELEME
  691. CALL ECROBJ('LISTMOTS',MLMOTS)
  692. RETURN
  693. *
  694. 340 CONTINUE
  695. IF(IMLU.NE.4) GO TO 350
  696. C PPc JG=NBCOUL
  697. JG=NBCOUL+1
  698. SEGINI,MLENTI
  699. C PPc DO IE1=1,NBCOUL
  700. DO IE1=1,NBCOUL+1
  701. LECT(IE1)=0
  702. ENDDO
  703. I1=LISOUS(/1)
  704. DO IE1=1,MAX(I1,1)
  705. IF (I1.EQ.0)THEN
  706. IPT2=MELEME
  707. ELSE
  708. IPT2=LISOUS(IE1)
  709. SEGACT,IPT2
  710. ENDIF
  711. DO IE2=1,ICOLOR(/1)
  712. C PPc LECT(ICOLOR(IE2))=1
  713. LECT(ICOLOR(IE2)+1)=1
  714. ENDDO
  715. SEGACT,IPT2
  716. ENDDO
  717. SEGACT,MELEME
  718. JGN=4
  719. JGM=0
  720. DO IE1=1,NBCOUL
  721. JGM=JGM+LECT(IE1)
  722. ENDDO
  723. SEGINI MLMOTS
  724. JGM=0
  725. C+PPc
  726. IF (LECT(1).NE.0)THEN
  727. JGM=JGM+1
  728. MOTS(JGM)='DEFA'
  729. ENDIF
  730. C+PPc
  731. C PPc DO IE1=1,NBCOUL
  732. DO IE1=2,NBCOUL+1
  733. IF (LECT(IE1).NE.0)THEN
  734. JGM=JGM+1
  735. C PPc MOTS(JGM)=NCOUL(IE1)
  736. MOTS(JGM)=NCOUL(IE1-1)
  737. ENDIF
  738. ENDDO
  739. SEGSUP,MLENTI
  740. SEGACT,MLMOTS
  741. CALL ECROBJ('LISTMOTS',MLMOTS)
  742. RETURN
  743. *
  744. 350 CONTINUE
  745. C+PP+
  746. IF(IMLU.NE.5) GO TO 360
  747. C+PP+
  748. * option segment 'COMPRIS' entre 2 points d une ligne
  749. * on recycle l operateur COMPRIS 01/2000 kich
  750. CALL ECROBJ('MAILLAGE',MELEME)
  751. CALL COMPRI
  752. RETURN
  753. C+PP+
  754. *
  755. * OPTION ZONE
  756. *
  757. 360 CONTINUE
  758. SEGACT,MELEME
  759. NBSOUS=LISOUS(/1)
  760. CALL LIRENT(IZONE,0,IRETOU)
  761. IF (IRETOU.NE.0)THEN
  762. *
  763. * EXTRACTION D'UNE ZONE
  764. *
  765. IF (NBSOUS.EQ.0.AND.IZONE.EQ.1)THEN
  766. CALL ECROBJ('MAILLAGE',MELEME)
  767. ELSEIF(IZONE.LE.NBSOUS)THEN
  768. CALL ECROBJ('MAILLAGE',LISOUS(IZONE))
  769. ELSE
  770. CALL ERREUR(279)
  771. ENDIF
  772. ELSE
  773. *
  774. * NB DE ZONE
  775. *
  776. IF(NBSOUS.EQ.0)NBSOUS=NBSOUS+1
  777. CALL ECRENT(NBSOUS)
  778. ENDIF
  779. SEGACT,MELEME
  780. RETURN
  781. *
  782. 9988 CONTINUE
  783. if (icpr.ne.0) then
  784. * write (6,*) ' extrel destruction de icpr'
  785. segsup icpr
  786. endif
  787. IRR=1
  788. RETURN
  789.  
  790. *-----------------------------------------------------------------------
  791. * EXTRACTION DES ELEMENTS D'UN CHAMP/ELEMENT
  792. *-----------------------------------------------------------------------
  793. 5000 CONTINUE
  794. IPCHE = 0
  795. IMM = 0
  796. IAB = 0
  797. IAV = 0
  798. ILAST = 0
  799. IPLIS = 0
  800. VALREF = XZERO
  801. VALRE2 = XZERO
  802. IPMAIL = 0
  803.  
  804. CALL LIROBJ('MCHAML',IPCHE,1,IRET)
  805. IF (IERR.NE.0) RETURN
  806. CALL LIRMOT(MOTM,9,IMM,1)
  807. IF (IERR.NE.0) RETURN
  808. IF (IMM.GT.2) THEN
  809. CALL LIRREE(VALREF,1,IRET)
  810. IF (IERR.NE.0) RETURN
  811. IF (IMM.EQ.9) THEN
  812. CALL LIRREE(VALRE2,1,IRET)
  813. IF (IERR.NE.0) RETURN
  814. ENDIF
  815. ENDIF
  816. CALL LIRMOT(MOABS,1,IAB,0)
  817. IF (IERR.NE.0) RETURN
  818. CALL LIRMOT(MOTAV,2,IAV,0)
  819. IF (IERR.NE.0) RETURN
  820. IF (IAV.EQ.0) IAV=1
  821. C Lecture de 'STRI' ou 'LARG' ==> Par defaut c'est LARG (Comme avant)
  822. CALL LIRMOT(MSCLE,2,ILAST,0)
  823. IF (IERR.NE.0) RETURN
  824. IF (ILAST.EQ.0) ILAST=2
  825. CALL LIROBJ('LISTMOTS',IPLIS,0,IRET)
  826. IF (IERR.NE.0) RETURN
  827.  
  828. CALL EXELCH(IPCHE,IMM,IAB,IAV,ILAST,IPLIS,VALREF,VALRE2,IPMAIL)
  829. IF (IERR.NE.0 .OR. IPMAIL.EQ.0) RETURN
  830.  
  831. CALL ECROBJ('MAILLAGE',IPMAIL)
  832.  
  833. RETURN
  834.  
  835. END
  836.  
  837.  
  838.  

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