Télécharger extrel.eso

Retour à la liste

Numérotation des lignes :

  1. C EXTREL SOURCE PV 20/03/30 21:19:18 10567
  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(nbpts)
  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. SEGACT,MCOORD
  546. SEGINI ICPR
  547. DO 231 I=1,nbpts
  548. ICPR(I)=0
  549. 231 CONTINUE
  550. SEGACT IPT1
  551. DO 232 J=1,IPT1.NUM(/2)
  552. ICPR(IPT1.NUM(1,J))=1
  553. 232 CONTINUE
  554. C TEST ET CREATION DU SEGMENT RESULTAT
  555. NBREF=0
  556. NBSOU=LISOUS(/1)
  557. IPT2=MELEME
  558. IF (NBSOU.NE.0) THEN
  559. NBNN=0
  560. NBELEM=0
  561. NBSOUS=NBSOU
  562. SEGINI IPT8
  563. ISO=0
  564. ENDIF
  565. DO 270 ISOUS=1,MAX(1,NBSOU)
  566. IF (NBSOU.NE.0) THEN
  567. IPT2=LISOUS(ISOUS)
  568. SEGACT IPT2
  569. ENDIF
  570. NBNN=IPT2.NUM(/1)
  571. NBELEM=IPT2.NUM(/2)
  572. ICOUNT=0
  573. DO 250 IEL=1,NBELEM
  574. IF (IMSLU.EQ.1) THEN
  575. DO 251 INOEU=1,NBNN
  576. IF(ICPR(IPT2.NUM(INOEU,IEL)).EQ.0) GOTO 250
  577. 251 CONTINUE
  578. ICOUNT=ICOUNT+1
  579. ELSE
  580. DO 252 INOEU=1,NBNN
  581. IF(ICPR(IPT2.NUM(INOEU,IEL)).NE.0) GOTO 253
  582. 252 CONTINUE
  583. GOTO 250
  584. 253 CONTINUE
  585. ICOUNT=ICOUNT+1
  586. ENDIF
  587. 250 CONTINUE
  588. NBSOUS=0
  589. NBREF=0
  590. NBEL=NBELEM
  591. NBELEM=ICOUNT
  592. ICOUNT=1
  593. IF(NBELEM.EQ.0) GOTO 260
  594. SEGINI IPT3
  595. IPT3.ITYPEL=IPT2.ITYPEL
  596. DO 255 IEL=1,NBEL
  597. IF (IMSLU.EQ.1) THEN
  598. DO 256 INOEU=1,NBNN
  599. IF(ICPR(IPT2.NUM(INOEU,IEL)).EQ.0) GOTO 255
  600. IPT3.NUM(INOEU,ICOUNT)=IPT2.NUM(INOEU,IEL)
  601. 256 CONTINUE
  602. IPT3.ICOLOR(ICOUNT)=IPT2.ICOLOR(IEL)
  603. ICOUNT=ICOUNT+1
  604. IF(ICOUNT.GT.NBELEM) GOTO 260
  605. ELSE
  606. IOOK=0
  607. DO 257 INOEU=1,NBNN
  608. IF(ICPR(IPT2.NUM(INOEU,IEL)).NE.0) IOOK=1
  609. IPT3.NUM(INOEU,ICOUNT)=IPT2.NUM(INOEU,IEL)
  610. 257 CONTINUE
  611. IF(IOOK.EQ.0) GOTO 255
  612. IPT3.ICOLOR(ICOUNT)=IPT2.ICOLOR(IEL)
  613. ICOUNT=ICOUNT+1
  614. IF(ICOUNT.GT.NBELEM) GOTO 260
  615. ENDIF
  616. 255 CONTINUE
  617. 260 CONTINUE
  618. IF (NBSOU.EQ.0) THEN
  619. IF (NBELEM.EQ.0) THEN
  620. IF (NOVER.EQ.0) THEN
  621. GOTO 9988
  622. ELSE
  623. call melvid(ILCOUR,IPT4)
  624. CALL ECROBJ('MAILLAGE',IPT4)
  625. RETURN
  626. ENDIF
  627. ENDIF
  628. GOTO 280
  629. ENDIF
  630. IF (NBELEM.NE.0) THEN
  631. IPT8.LISOUS(ISOUS)=IPT3
  632. ISO=ISO+1
  633. SEGACT IPT3
  634. ENDIF
  635. 270 CONTINUE
  636. IF (ISO.EQ.1) THEN
  637. SEGSUP IPT8
  638. GOTO 280
  639. ENDIF
  640. IPT3=IPT8
  641. IF(ISO.EQ.NBSOU) GOTO 280
  642. NBSOUS=ISO
  643. NBREF=0
  644. NBNN=0
  645. NBELEM=0
  646. SEGINI IPT4
  647. ISO=0
  648. DO 275 IS=1,NBSOU
  649. IF(IPT3.LISOUS(IS).EQ.0) GOTO 275
  650. ISO=ISO+1
  651. IPT4.LISOUS(ISO)=IPT3.LISOUS(IS)
  652. 275 CONTINUE
  653. IF (ISO.EQ.0) THEN
  654. IF (NOVER.EQ.0) THEN
  655. GOTO 9988
  656. ELSE
  657. CALL melvid(ILCOUR,IPT4)
  658. CALL ECROBJ('MAILLAGE',IPT4)
  659. RETURN
  660. ENDIF
  661. ENDIF
  662. SEGSUP IPT3
  663. IPT3=IPT4
  664. 280 CONTINUE
  665. SEGACT IPT3
  666. CALL ECROBJ('MAILLAGE',IPT3)
  667. SEGACT IPT1
  668. SEGSUP ICPR
  669. RETURN
  670. 330 CONTINUE
  671. IF(IMLU.NE.3) GO TO 340
  672. *
  673. * OPTION 'TYPE' SELON PROPOSITION ISPRA
  674. *
  675. I1 = meleme.LISOUS(/1)
  676. JGN=4
  677. JGM=MAX(1,I1)
  678. SEGINI MLMOTS
  679. IF (I1.EQ.0) THEN
  680. MOTS(1)=NOMS(ITYPEL)
  681. ELSE
  682. DO 33 I=1,I1
  683. IPT2=LISOUS(I)
  684. SEGACT IPT2
  685. IDES=IPT2.ITYPEL
  686. MOTS(I)=NOMS(IDES)
  687. SEGACT IPT2
  688. 33 CONTINUE
  689. ENDIF
  690. SEGACT MLMOTS
  691. SEGACT,MELEME
  692. CALL ECROBJ('LISTMOTS',MLMOTS)
  693. RETURN
  694. *
  695. 340 CONTINUE
  696. C
  697. C---- LISTMOTS des COULeurs
  698. IF(IMLU.NE.4) GO TO 350
  699. C
  700. JG=NBCOUL+1
  701. SEGINI,MLENTI
  702. DO IE1=1,NBCOUL+1
  703. LECT(IE1)=0
  704. ENDDO
  705. I1=LISOUS(/1)
  706. DO IE1=1,MAX(I1,1)
  707. IF (I1.EQ.0)THEN
  708. IPT2=MELEME
  709. ELSE
  710. IPT2=LISOUS(IE1)
  711. SEGACT,IPT2
  712. ENDIF
  713. DO IE2=1,IPT2.ICOLOR(/1)
  714. LECT(IPT2.ICOLOR(IE2)+1)=1
  715. ENDDO
  716. C SEGACT,IPT2
  717. ENDDO
  718. C SEGACT,MELEME
  719. C
  720. JGN=4
  721. JGM=0
  722. DO IE1=1,NBCOUL
  723. JGM=JGM+LECT(IE1)
  724. ENDDO
  725. SEGINI MLMOTS
  726. JGM=0
  727. IF (LECT(1).NE.0)THEN
  728. JGM=JGM+1
  729. MOTS(JGM)='DEFA'
  730. ENDIF
  731. C
  732. DO IE1=2,NBCOUL+1
  733. IF (LECT(IE1).NE.0)THEN
  734. JGM=JGM+1
  735. MOTS(JGM)=NCOUL(IE1-1)
  736. ENDIF
  737. ENDDO
  738. SEGSUP,MLENTI
  739. SEGACT,MLMOTS
  740. CALL ECROBJ('LISTMOTS',MLMOTS)
  741. RETURN
  742. *
  743. 350 CONTINUE
  744. C+PP+
  745. IF(IMLU.NE.5) GO TO 360
  746. C+PP+
  747. * option segment 'COMPRIS' entre 2 points d une ligne
  748. * on recycle l operateur COMPRIS 01/2000 kich
  749. CALL ECROBJ('MAILLAGE',MELEME)
  750. CALL COMPRI
  751. RETURN
  752. C+PP+
  753. *
  754. * OPTION ZONE
  755. *
  756. 360 CONTINUE
  757. SEGACT,MELEME
  758. NBSOUS=LISOUS(/1)
  759. CALL LIRENT(IZONE,0,IRETOU)
  760. IF (IRETOU.NE.0)THEN
  761. *
  762. * EXTRACTION D'UNE ZONE
  763. *
  764. IF (NBSOUS.EQ.0.AND.IZONE.EQ.1)THEN
  765. CALL ECROBJ('MAILLAGE',MELEME)
  766. ELSEIF(IZONE.LE.NBSOUS)THEN
  767. CALL ECROBJ('MAILLAGE',LISOUS(IZONE))
  768. ELSE
  769. CALL ERREUR(279)
  770. ENDIF
  771. ELSE
  772. *
  773. * NB DE ZONE
  774. *
  775. IF(NBSOUS.EQ.0)NBSOUS=NBSOUS+1
  776. CALL ECRENT(NBSOUS)
  777. ENDIF
  778. SEGACT,MELEME
  779. RETURN
  780. *
  781. 9988 CONTINUE
  782. if (icpr.ne.0) then
  783. * write (6,*) ' extrel destruction de icpr'
  784. segsup icpr
  785. endif
  786. IRR=1
  787. RETURN
  788.  
  789. *-----------------------------------------------------------------------
  790. * EXTRACTION DES ELEMENTS D'UN CHAMP/ELEMENT
  791. *-----------------------------------------------------------------------
  792. 5000 CONTINUE
  793. IPCHE = 0
  794. IMM = 0
  795. IAB = 0
  796. IAV = 0
  797. ILAST = 0
  798. IPLIS = 0
  799. VALREF = XZERO
  800. VALRE2 = XZERO
  801. IPMAIL = 0
  802.  
  803. CALL LIROBJ('MCHAML',IPCHE,1,IRET)
  804. IF (IERR.NE.0) RETURN
  805. CALL LIRMOT(MOTM,9,IMM,1)
  806. IF (IERR.NE.0) RETURN
  807. IF (IMM.GT.2) THEN
  808. CALL LIRREE(VALREF,1,IRET)
  809. IF (IERR.NE.0) RETURN
  810. IF (IMM.EQ.9) THEN
  811. CALL LIRREE(VALRE2,1,IRET)
  812. IF (IERR.NE.0) RETURN
  813. ENDIF
  814. ENDIF
  815. CALL LIRMOT(MOABS,1,IAB,0)
  816. IF (IERR.NE.0) RETURN
  817. CALL LIRMOT(MOTAV,2,IAV,0)
  818. IF (IERR.NE.0) RETURN
  819. IF (IAV.EQ.0) IAV=1
  820. C Lecture de 'STRI' ou 'LARG' ==> Par defaut c'est LARG (Comme avant)
  821. CALL LIRMOT(MSCLE,2,ILAST,0)
  822. IF (IERR.NE.0) RETURN
  823. IF (ILAST.EQ.0) ILAST=2
  824. CALL LIROBJ('LISTMOTS',IPLIS,0,IRET)
  825. IF (IERR.NE.0) RETURN
  826.  
  827. CALL EXELCH(IPCHE,IMM,IAB,IAV,ILAST,IPLIS,VALREF,VALRE2,IPMAIL)
  828. IF (IERR.NE.0 .OR. IPMAIL.EQ.0) RETURN
  829.  
  830. CALL ECROBJ('MAILLAGE',IPMAIL)
  831.  
  832. RETURN
  833.  
  834. END
  835.  
  836.  
  837.  
  838.  
  839.  
  840.  

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