Télécharger extrel.eso

Retour à la liste

Numérotation des lignes :

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

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