Télécharger extrel.eso

Retour à la liste

Numérotation des lignes :

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