Télécharger extrel.eso

Retour à la liste

Numérotation des lignes :

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

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