Télécharger prcont.eso

Retour à la liste

Numérotation des lignes :

  1. C PRCONT SOURCE JC220346 17/02/27 21:15:00 9324
  2. ************************************************************************
  3. * NOM : PRCONT
  4. * DESCRIPTION : Construit le contour d'un objet maillage
  5. * (fonctionne suivant un principe inspire de TRAC)
  6. ************************************************************************
  7. * APPELE PAR : pilot.eso
  8. ************************************************************************
  9. * ENTREES :: aucune
  10. * SORTIES :: aucune
  11. ************************************************************************
  12. * SYNTAXE (GIBIANE) :
  13. *
  14. * GEO1 = CONTOUR ('NOID') (|'EXTE'|) GEO2 ;
  15. * |'INTE'|
  16. * |'TOUT'|
  17. *
  18. ************************************************************************
  19. SUBROUTINE PRCONT
  20.  
  21. IMPLICIT INTEGER(I-N)
  22.  
  23. -INC CCOPTIO
  24. -INC CCGEOME
  25. -INC SMELEME
  26. -INC SMCOORD
  27. -INC CCASSIS
  28.  
  29. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  30. SEGMENT IDCP(ITE)
  31. SEGMENT KON(NBCON,NMAX,3)
  32.  
  33. CHARACTER*8 CHAIN1
  34.  
  35. PARAMETER(NMOT1=3,NMOT2=1)
  36. CHARACTER*4 LMOT1(NMOT1),LMOT2(NMOT2)
  37. DATA LMOT1/'EXTE','INTE','TOUT'/
  38. DATA LMOT2/'NOID'/
  39.  
  40.  
  41. * +---------------------------------------------------------------+
  42. * | L E C T U R E D E S A R G U M E N T S |
  43. * +---------------------------------------------------------------+
  44.  
  45. * LECTURE DES MOTS-CLES FACULTATIFS
  46. CALL LIRMOT(LMOT1,NMOT1,IMOT1,0)
  47. IF (IMOT1.EQ.0) IMOT1=1
  48. CALL LIRMOT(LMOT2,NMOT2,IMOT2,0)
  49.  
  50. * LECTURE DU MAILLAGE
  51. CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
  52. IF (IERR.NE.0) RETURN
  53. IPT8=MELEME
  54.  
  55. * ON VA VERIFIER QUE LE CONTOUR DEMANDE N'A PAS DEJA ETE CONSTRUIT
  56. SEGACT,MELEME
  57. IF (LISREF(/1).EQ.1.AND.IMOT1.EQ.1) THEN
  58. IPT1=LISREF(1)
  59. CALL ECROBJ('MAILLAGE',IPT1)
  60. SEGDES,MELEME
  61. RETURN
  62. ENDIF
  63.  
  64. * +---------------------------------------------------------------+
  65. * | C O N N E C T I V I T E D U M A I L L A G E |
  66. * +---------------------------------------------------------------+
  67. *
  68. * REMPLISSAGE DES TABLEAUX DE CORRESPONDANCE LOCALE/GLOBALE AVEC
  69. * SEULEMENT LES NOEUDS SOMMETS (i.e. PAS DE NOEUDS MILIEUX)
  70. * **************************************************************
  71.  
  72. SEGACT,MCOORD
  73. SEGINI,ICPR
  74. ITE=0
  75. IPT1=MELEME
  76. DO 3 I=1,MAX(1,LISOUS(/1))
  77. IF (LISOUS(/1).NE.0) THEN
  78. IPT1=LISOUS(I)
  79. SEGACT,IPT1
  80. ENDIF
  81. K=IPT1.ITYPEL
  82.  
  83. * Le test ci-dessous filtre les elements non surfaciques
  84. IF (K.NE.KSURF(K)) GOTO 8
  85.  
  86. * Parcours des noeuds situes aux sommets de tous les elements
  87. IDEP=NSPOS(K)
  88. IF (NBSOM(K).GT.0) THEN
  89. IFEP=IDEP+NBSOM(K)-1
  90. ELSE
  91. * Cas particulier de l'element POLYgone
  92. IFEP=IDEP+IPT1.NUM(/1)-1
  93. ENDIF
  94. IF (IFEP.LT.IDEP) GOTO 8
  95. DO 4 JJ=IDEP,IFEP
  96. J=IBSOM(JJ)
  97. DO 401 K=1,IPT1.NUM(/2)
  98. IPOIT=IPT1.NUM(J,K)
  99. IF (ICPR(IPOIT).NE.0) GOTO 7
  100. ITE=ITE+1
  101. ICPR(IPOIT)=ITE
  102. 7 CONTINUE
  103. 401 CONTINUE
  104. 4 CONTINUE
  105. 8 CONTINUE
  106. 3 CONTINUE
  107. *
  108. IF (ITE.EQ.0) THEN
  109. SEGSUP,ICPR
  110. CALL ERREUR(16)
  111. RETURN
  112. ENDIF
  113. *
  114. SEGINI,IDCP
  115. DO 40 I=1,ICPR(/1)
  116. IF (ICPR(I).EQ.0) GOTO 40
  117. IDCP(ICPR(I))=I
  118. 40 CONTINUE
  119.  
  120.  
  121. * REMPLISSAGE DU TABLEAU DE CONNECTIVITE VIA LES ARETES KON(I,J,K)
  122. * ******************************************************************
  123. * => KON(I,J,K) CONTIENT LES INFORMATIONS ASSOCIEES A LA I-EME
  124. * ARETE CONNECTEE AU J-EME NOEUD (NUMEROTATION LOCALE)
  125. * K=1 NOEUD A L'AUTRE EXTREMITE DE L'ARETE
  126. * K=2 NOEUD MILIEU (=1 POUR LES ELT D'ORDRE 1)
  127. * K=3 DESIGNE LA COULEUR DE L'ARETE + 1
  128. *
  129. * => I EST COMPRIS ENTRE 1 ET NBCON=7, OR IL PEUT Y AVOIR BEAUCOUP
  130. * PLUS D'ARETES CONNECTEES A UN NOEUD J DONNE
  131. * SOLUTION : LA 7EME ARETE EST STOCKEE DANS DANS KON(1,L,K) AVEC
  132. * L=KON(7,J,1) ET AINSI DE SUITE POUR LES SUIVANTES
  133. * (CE QUI EXPLIQUE QUE J VARIE DE 1 A NMAX>ITE)
  134. *
  135. * => LE SIGNE DEVANT LE NUMERO DU NOEUD MILIEU (K=2) PEUT ETRE
  136. * POSITIF OU NEGATIF SELON LE SENS DE PARCOURS DU CONTOUR
  137. *
  138. * => LA DEUXIEME FOIS QU'UNE ARETE EST RENCONTREE, LE NUMERO DU
  139. * NOEUD D'EXTREMITE (K=1) DEVIENT NEGATIF => ARETE HORS CONTOUR
  140. *
  141. * => LA TROISIEME FOIS QU'UNE ARETE EST RECONTREE, LE NUMERO DE LA
  142. * COULEUR (K=3) DEVIENT NEGATIF => CONTOUR INTERNE DETECTE
  143. * ******************************************************************
  144. NBCON=7
  145. NBCONR=NBCON-1
  146. NMAX=(10*ITE)/NBCON
  147. SEGINI,KON
  148.  
  149. * NBNN designe le nombre de noeuds par arete (type = SEG2 ou SEG3)
  150. * COMPT est incremente des qu'on recontre un nouveau type de segment
  151. NBNN=0
  152. COMPT=0
  153.  
  154. * ICHAIN est l'indice J "apres debordement" permettant de definir
  155. * plus de 6 aretes pour un meme noeud
  156. ICHAIN=ITE
  157.  
  158. * BOUCLE SUR LES SOUS-MAILLAGES ELEMENTAIRES
  159. IPT1=MELEME
  160. DO 30 IO=1,MAX(1,LISOUS(/1))
  161. IF (LISOUS(/1).NE.0) IPT1=LISOUS(IO)
  162.  
  163. K=IPT1.ITYPEL
  164.  
  165. * Le test ci-dessous filtre les sous-maillages non surfaciques
  166. IF (K.NE.KSURF(K)) GOTO 21
  167.  
  168. * Reperage des indices de debut/fin de parcours de tous les
  169. * noeuds de la face (tableau LFAC)
  170. KK=LTEL(2,K)
  171. ITYP=LDEL(1,KK)
  172. IF (NBNN.NE.KDEGRE(K)) THEN
  173. NBNN=KDEGRE(K)
  174. COMPT=COMPT+1
  175. ENDIF
  176. IPAS=NBNN-1
  177. IDEP=LDEL(2,KK)
  178. IF (ITYP.NE.6) THEN
  179. IFEP=IDEP+KDFAC(1,ITYP)-1
  180. * [SG 2016-07-11] Pour les faces TRI7 et QUA9, on ignore le
  181. * dernier point (centre de la face)
  182. IF (ITYP.EQ.7.OR.ITYP.EQ.8) IFEP=IFEP-1
  183. ELSE
  184. * Cas particulier de l'element POLYgone
  185. IFEP= IDEP+IPT1.NUM(/1)-1
  186. ENDIF
  187.  
  188. * PARCOURS DES NOEUDS SOMMETS DE TOUS LES ELEMENTS
  189. DO 22 I=1,IPT1.NUM(/2)
  190. DO 221 J=IDEP,IFEP,IPAS
  191.  
  192. * DETERMINATION DES CARACTERISTIQUES DE L'ARETE
  193. * => NI=sommet courant
  194. * => NJ=sommet a l'autre extremite de l'arete
  195. * => NMIL=noeud milieu si existant (ou alors 1)
  196. * => KSCOL=couleur+1
  197. NMIL=1
  198. * (VALEUR QUI PERMET DE DISTINGUER SEG2 ET SEG3 CAR LE
  199. * NOEUD GLOBAL 1 NE SERA JAMAIS UN NOEUD MILIEU)
  200. N1=ICPR(IPT1.NUM(LFAC(J),I))
  201. JSUIV=J+IPAS
  202. IF (JSUIV.GT.IFEP) JSUIV=IDEP
  203. N2=ICPR(IPT1.NUM(LFAC(JSUIV),I))
  204. IF (IPAS.EQ.2) NMIL=IPT1.NUM(LFAC(J+1),I)
  205. NI=N1
  206. NJ=N2
  207. IF (N1*N2.EQ.0) THEN
  208. CALL ERREUR(26)
  209. SEGSUP,KON,ICPR,IDCP
  210. SEGDES,MELEME
  211. RETURN
  212. ENDIF
  213. KSCOL=IPT1.ICOLOR(I)+1
  214.  
  215. * PARCOURS DU TABLEAU KON POUR Y AJOUTER L'ARETE COURANTE,
  216. * OU POUR INDIQUER QU'ON L'A VUE 2 OU 3 FOIS
  217. * (en cas d'ajout, IPO permet d'ajouter aussi dans KON
  218. * l'arete parcourue en sens inverse)
  219. IPO=0
  220. 23 CONTINUE
  221.  
  222. * On cherche si l'arete existe deja, ou bien sinon la
  223. * premiere place libre pour l'ajouter
  224. KINT=1
  225. 120 CONTINUE
  226. 24 DO 25 K=KINT,NBCONR
  227. IF (KON(K,NI,1).EQ.0) GOTO 26
  228. IF (ABS(KON(K,NI,1)).EQ.NJ) GOTO 27
  229. 25 CONTINUE
  230. * Au-dela de I=6 : soit on a trouve une place libre, soit
  231. * on continue a parcourir KON a l'indice J de "debordement"
  232. * (car il y a deja au moins 7 aretes associees a NI)
  233. IF (KON(NBCON,NI,1).EQ.0) GOTO 28
  234. NI=KON(NBCON,NI,1)
  235. GOTO 24
  236.  
  237. * ON AVAIT DEJA RENCONTRE CETTE ARETE...
  238. 27 IF (ABS(KON(K,NI,2)).EQ.ABS(NMIL)) THEN
  239. IF (KON(K,NI,1).GT.0) THEN
  240. * ...UNE SEULE FOIS => ON L'EXCLUT DU CONTOUR
  241. KON(K,NI,1)=-NJ
  242. ELSE
  243. * ...AU MOINS 2 FOIS => ON L'AJOUTE AU CONTOUR INTERNE
  244. KON(K,NI,3)=-KSCOL
  245. ENDIF
  246. GOTO 29
  247. * Fausse alerte : le noeud milieu n'est pas le meme !
  248. ELSE
  249. KINT=K+1
  250. GOTO 120
  251. ENDIF
  252.  
  253. * ARETE JAMAIS RENCONTREE : AJOUT A LA PREMIERE PLACE LIBRE
  254. 26 KON(K,NI,1)=NJ
  255. KON(K,NI,2)=NMIL
  256. KON(K,NI,3)=KSCOL
  257. GOTO 29
  258.  
  259. * ARETE JAMAIS RENCONTREE, MAIS LA PREMIERE PLACE LIBRE
  260. * SE TROUVE DANS LE PROCHAIN BLOC DE 6
  261. 28 ICHAIN=ICHAIN+1
  262. IF (ICHAIN.GE.NMAX) THEN
  263. NMAX=NMAX*2
  264. SEGADJ,KON
  265. ENDIF
  266. KON(NBCON,NI,1)=ICHAIN
  267. K=1
  268. NI=ICHAIN
  269. GOTO 26
  270.  
  271. * A CHAQUE FOIS QU'UNE NOUVELLE ARETE EST RENCONTREE, ON
  272. * AJOUTE AUSSI DANS KON CELLE PARCOURUE EN SENS INVERSE
  273. 29 IF (IPO.EQ.1) GOTO 221
  274. NMIL=-NMIL
  275. NI=N2
  276. NJ=N1
  277. IPO=1
  278. GOTO 23
  279. 221 CONTINUE
  280. 22 CONTINUE
  281.  
  282. 21 CONTINUE
  283. IF (LISOUS(/1).NE.0) SEGDES,IPT1
  284.  
  285. 30 CONTINUE
  286.  
  287. * WARNING : contour complexe detecte (SEG2 et SEG3)
  288. IF (COMPT.GT.1) CALL ERREUR(-333)
  289.  
  290. * ####################################################
  291. * IMPRESSIONS POUR DEBUGAGE (OPTI 'IMPI')
  292. IF (IIMPI.NE.0) THEN
  293.  
  294. * CONTENU DU TABLEAU ICPR
  295. WRITE(IOIMP,FMT='("ICPR(",I7,")=",I7)')(I,ICPR(I),I=1,ICPR(/1))
  296. WRITE(IOIMP,*) '********************'
  297.  
  298. * CONTENU DU TABLEAU IDCP
  299. WRITE(IOIMP,FMT='("IDCP(",I7,")=",I7)')(I,IDCP(I),I=1,IDCP(/1))
  300. WRITE(IOIMP,*) '********************'
  301.  
  302. * CONTENU DU TABLEAU KON
  303. IF (IIMPI.EQ.2) THEN
  304. DO J=1,NMAX
  305. WRITE(IOIMP,FMT='(A,I7,A,I7)') 'J=',J,'/',NMAX
  306. WRITE(IOIMP,FMT='(3I7)') ((KON(I,J,K),K=1,3),I=1,NBCON)
  307. ENDDO
  308. ENDIF
  309.  
  310. * ON VERIFIE SI CHAQUE NOEUD DU CONTOUR EST BIEN RELIE UNIQUEMENT
  311. * A DEUX ELEMENTS
  312. NNOEUD=0
  313. CHAIN1='NODE'
  314. DO 70 NI=1,ITE
  315. NINTT=NI
  316. NKON=0
  317. 72 CONTINUE
  318. DO 71 J=1,NBCONR
  319. IF (KON(J,NINTT,1).EQ.0) GOTO 71
  320. IF (KON(J,NINTT,1).GT.0) NKON=NKON+1
  321. 71 CONTINUE
  322. IF (KON(NBCON,NINTT,1).NE.0) THEN
  323. NINTT=KON(NBCON,NINTT,1)
  324. GOTO 72
  325. ENDIF
  326. IF (NKON.GT.2) THEN
  327. NNOEUD=NNOEUD+1
  328. JP1=IDCP(NI)
  329. NNO=NNOEUD
  330. IF (NNO.LE.9) THEN
  331. WRITE(CHAIN1(5:5),FMT='(I1)') NNO
  332. ELSEIF(NNO.LE.99) THEN
  333. WRITE(CHAIN1(5:6),FMT='(I2)') NNO
  334. ELSEIF(NNO.LE.999) THEN
  335. WRITE(CHAIN1(5:7),FMT='(I3)') NNO
  336. ELSEIF(NNO.LE.9999) THEN
  337. WRITE(CHAIN1(5:8),FMT='(I4)') NNO
  338. ELSEIF(NNO.LE.99999) THEN
  339. WRITE(CHAIN1(4:8),FMT='(I5)') NNO
  340. ELSEIF(NNO.LE.999999) THEN
  341. WRITE(CHAIN1(3:8),FMT='(I6)') NNO
  342. ENDIF
  343. CALL NOMOBJ('POINT',CHAIN1,JP1)
  344. MOTERR(1:8)=CHAIN1
  345. INTERR(1)=NKON
  346. CALL ERREUR(-335)
  347. ENDIF
  348. 70 CONTINUE
  349.  
  350. ENDIF
  351. * ####################################################
  352.  
  353. SEGDES,MELEME
  354. SEGSUP,ICPR
  355.  
  356.  
  357. * CREATION DU MAILLAGE CONTENANT LE CONTOUR
  358. * *****************************************
  359.  
  360. * Cas ou le contour est un objet geometrique simple
  361. * (uniquement des SEG2 ou uniquement des SEG3)
  362. * =================================================
  363. IF (COMPT.EQ.1) THEN
  364.  
  365. * ON COMMENCE PAR COMPTER LE NOMBRE D'ELEMENTS DU CONTOUR
  366. NBELEM=0
  367. DO 41 J=1,ITE
  368. JJ=J
  369. 43 DO 42 I=1,NBCONR
  370. * On prend bien soin de ne compter les aretes que dans
  371. * un seul sens !
  372. KON1=KON(I,JJ,1)
  373. KON3=KON(I,JJ,3)
  374. IF ((IMOT1.EQ.3.AND.(ABS(KON1).LT.J.OR.KON1*KON3.LE.0))
  375. & .OR.(IMOT1.EQ.2.AND.(-KON1.LT.J.OR.KON3.GT.0))
  376. & .OR.(IMOT1.EQ.1.AND.(KON1.LT.J.OR.KON3.LT.0))) GOTO 42
  377. NBELEM=NBELEM+1
  378. 42 CONTINUE
  379. IF (KON(NBCON,JJ,1).EQ.0) GOTO 41
  380. JJ=KON(NBCON,JJ,1)
  381. GOTO 43
  382. 41 CONTINUE
  383.  
  384. IF (IIMPI.NE.0) WRITE(IOIMP,1111) NBELEM
  385. 1111 FORMAT(' NOMBRE D''ELEMENTS DU CONTOUR : ',I6)
  386.  
  387. IF (NBELEM.EQ.0.AND.IMOT2.EQ.0) THEN
  388. CALL ERREUR(26)
  389. GOTO 64
  390. ENDIF
  391.  
  392. * CREATION DU CHAPEAU DE L'OBJET MELEME
  393. NBSOUS=0
  394. NBREF=0
  395. SEGINI,MELEME
  396. ITYPEL=NBNN
  397.  
  398. * REMPLISSAGE SELON L'OPTION IMOT1 DEMANDEE (EXTE, INTE, TOUT)
  399. IEL=0
  400.  
  401. * Recherche d'une arete orientee dans le sens +1, pas encore
  402. * ajoutee au contour
  403. KAUX=1
  404. 50 K=KAUX
  405. KAUXR=KAUX
  406. 51 DO 52 KL=1,NBCONR
  407. IF (KON(KL,K,2).LT.0) GOTO 52
  408. IT=KON(KL,K,1)
  409. IT3=KON(KL,K,3)
  410. IF ((IMOT1.EQ.1.AND.(IT.LT.0.OR.IT3.LT.0)).OR.
  411. & (IMOT1.EQ.2.AND.(IT.GT.0.OR.IT3.GT.0)).OR.
  412. & (IMOT1.EQ.3.AND.(IT*IT3.LT.0))) GOTO 52
  413. IF (IT.EQ.0) GOTO 53
  414. GOTO 54
  415. 52 CONTINUE
  416. K=KON(NBCON,K,1)
  417. IF (K.NE.0) GOTO 51
  418. 53 KAUX=KAUX+1
  419. IF (KAUX.EQ.ITE+1) GOTO 63
  420. GOTO 50
  421.  
  422. 54 KPRESS=KAUXR
  423. GOTO 55
  424. * Recherche de l'arete suivante
  425. 57 KL=1
  426. 55 DO 56 L=KL,NBCONR
  427. M=KON(L,K,1)
  428. IF (M.EQ.0) GOTO 53
  429. M2=KON(L,K,2)
  430. M3=KON(L,K,3)
  431. IF ((IMOT1.EQ.1.AND.(M.LT.0.OR.M3.LT.0)).OR.
  432. & (IMOT1.EQ.2.AND.(M.GT.0.OR.M3.GT.0)).OR.
  433. & (IMOT1.EQ.3.AND.(M*M3.LT.0))) GOTO 56
  434. GOTO 58
  435. 56 CONTINUE
  436. K=KON(NBCON,K,1)
  437. IF (K.EQ.0) GOTO 53
  438. GOTO 57
  439.  
  440. * Ajout d'un element SEG2 ou SEG3 joignant KPRESS a M
  441. 58 IEL=IEL+1
  442. MM=ABS(M)
  443. NUM(1,IEL)=IDCP(KPRESS)
  444. NUM(NBNN,IEL)=IDCP(MM)
  445. ICOLOR(IEL)=ABS(M3)-1
  446. IF (NBNN.EQ.3) NUM(2,IEL)=ABS(M2)
  447.  
  448. * On change le signe de KON(*,*,1) pour indiquer que l'element
  449. * a deja ete ajoute au contour
  450. KON(L,K,1)=-M
  451. * Idem, pour l'arete parcourue en sens inverse...
  452. M1=MM
  453. 59 DO 60 L=1,NBCONR
  454. IF (KON(L,M1,2).NE.-M2) GOTO 60
  455. IF (KON(L,M1,1).EQ.0) GOTO 62
  456. IF (ABS(KON(L,M1,1)).EQ.KPRESS) GOTO 61
  457. 60 CONTINUE
  458. M1=KON(NBCON,M1,1)
  459. IF (M1.EQ.0) GOTO 62
  460. GOTO 59
  461. 61 KON(L,M1,1)=-KON(L,M1,1)
  462. 62 KPRESS=MM
  463. * ...puis on continue de suivre le contour
  464. GOTO 57
  465. 63 CONTINUE
  466.  
  467. SEGDES,MELEME
  468. CALL ECROBJ('MAILLAGE',MELEME)
  469.  
  470. * ON INSCRIT SEULEMENT LE CONTOUR EXTERIEUR DANS LES
  471. * REFERENCES DU MAILLAGE INITIAL
  472. SEGACT,IPT8
  473. IF (IPT8.LISREF(/1).EQ.0.AND.IMOT1.EQ.1) THEN
  474. NBREF=1
  475. NBNN=IPT8.NUM(/1)
  476. NBELEM=IPT8.NUM(/2)
  477. NBSOUS=IPT8.LISOUS(/1)
  478. SEGADJ,IPT8
  479. IPT8.LISREF(1)=MELEME
  480. ENDIF
  481. SEGDES,IPT8
  482.  
  483. * Cas ou le contour est un objet geometrique complexe
  484. * ===================================================
  485. ELSE
  486.  
  487. * CREATION DU CHAPEAU DE L'OBJET MELEME
  488. NBSOUS=2
  489. NBREF=0
  490. NBELEM=0
  491. SEGINI,MELEME
  492.  
  493. * +------+
  494. * | SEG3 |
  495. * +------+
  496.  
  497. * ON COMMENCE PAR COMPTER LE NOMBRE D'ELEMENTS SEG3 DU CONTOUR
  498. NBELEM=0
  499. DO 141 J=1,ITE
  500. JJ=J
  501. 143 DO 142 I=1,NBCONR
  502. * Le noeud local 1 ne peut pas etre un noeud milieu
  503. * => On est en presence d'un SEG2
  504. IF (ABS(KON(I,JJ,2)).EQ.1) GOTO 142
  505. * On prend bien soin de ne compter les aretes que dans
  506. * un seul sens !
  507. KON1=KON(I,JJ,1)
  508. KON3=KON(I,JJ,3)
  509. IF ((IMOT1.EQ.3.AND.(ABS(KON1).LT.J.OR.KON1*KON3.LE.0))
  510. & .OR.(IMOT1.EQ.2.AND.(-KON1.LT.J.OR.KON3.GT.0))
  511. & .OR.(IMOT1.EQ.1.AND.(KON1.LT.J.OR.KON3.LT.0))) GOTO 142
  512. NBELEM=NBELEM+1
  513. 142 CONTINUE
  514. IF (KON(NBCON,JJ,1).EQ.0) GOTO 141
  515. JJ=KON(NBCON,JJ,1)
  516. GOTO 143
  517. 141 CONTINUE
  518.  
  519. IF (IIMPI.NE.0) WRITE(IOIMP,1111) NBELEM
  520. IF (IERR.NE.0) GOTO 64
  521.  
  522. * CREATION DU CHAPEAU DU PREMIER SOUS-MELEME
  523. NBNN=3
  524. NBSOUS=0
  525. NBREF=0
  526. SEGINI,IPT3
  527. IPT3.ITYPEL=NBNN
  528.  
  529. * REMPLISSAGE SELON L'OPTION IMOT1 DEMANDEE (EXTE, INTE, TOUT)
  530. IEL=0
  531.  
  532. * Recherche d'une arete orientee dans le sens +1, pas encore
  533. * ajoutee au contour de SEG3
  534. KAUX=1
  535. 150 K=KAUX
  536. KAUXR=KAUX
  537. 151 DO 152 KL=1,NBCONR
  538. IF (KON(KL,K,2).EQ.1.OR.KON(KL,K,2).LT.0) GOTO 152
  539. IT=KON(KL,K,1)
  540. IT3=KON(KL,K,3)
  541. IF ((IMOT1.EQ.1.AND.(IT.LT.0.OR.IT3.LT.0)).OR.
  542. & (IMOT1.EQ.2.AND.(IT.GT.0.OR.IT3.GT.0)).OR.
  543. & (IMOT1.EQ.3.AND.(IT*IT3.LT.0))) GOTO 152
  544. IF (IT.EQ.0) GOTO 153
  545. GOTO 154
  546. 152 CONTINUE
  547. K=KON(NBCON,K,1)
  548. IF (K.NE.0) GOTO 151
  549. 153 KAUX=KAUX+1
  550. IF (KAUX.EQ.ITE+1) GOTO 163
  551. GOTO 150
  552.  
  553. 154 KPRESS=KAUXR
  554. GOTO 155
  555. * Recherche de l'arete SEG3 suivante
  556. 157 KL=1
  557. 155 DO 156 L=KL,NBCONR
  558. M=KON(L,K,1)
  559. IF (M.EQ.0) GOTO 153
  560. M2=KON(L,K,2)
  561. IF (ABS(M2).EQ.1) GOTO 156
  562. M3=KON(L,K,3)
  563. IF ((IMOT1.EQ.1.AND.(M.LT.0.OR.M3.LT.0)).OR.
  564. & (IMOT1.EQ.2.AND.(M.GT.0.OR.M3.GT.0)).OR.
  565. & (IMOT1.EQ.3.AND.(M*M3.LT.0))) GOTO 156
  566. GOTO 158
  567. 156 CONTINUE
  568. K=KON(NBCON,K,1)
  569. IF (K.EQ.0) GOTO 153
  570. GOTO 157
  571.  
  572. * Ajout d'un element SEG3 joignant KPRESS a M
  573. 158 IEL=IEL+1
  574. MM=ABS(M)
  575. IPT3.NUM(1,IEL)=IDCP(KPRESS)
  576. IPT3.NUM(NBNN,IEL)=IDCP(MM)
  577. IPT3.ICOLOR(IEL)=ABS(M3)-1
  578. IPT3.NUM(2,IEL)=ABS(M2)
  579.  
  580. * On change le signe de KON(*,*,1) pour indiquer que l'element
  581. * a deja ete ajoute au contour
  582. KON(L,K,1)=-M
  583. * Idem, pour l'arete parcourue en sens inverse...
  584. M1=MM
  585. 159 DO 160 L=1,NBCONR
  586. IF (KON(L,M1,2).NE.-M2) GOTO 160
  587. IF (KON(L,M1,1).EQ.0) GOTO 162
  588. IF (ABS(KON(L,M1,1)).EQ.KPRESS) GOTO 161
  589. 160 CONTINUE
  590. M1=KON(NBCON,M1,1)
  591. IF (M1.EQ.0) GOTO 162
  592. GOTO 159
  593. 161 KON(L,M1,1)=-KON(L,M1,1)
  594. 162 KPRESS=MM
  595. * ...puis on continue de suivre le contour
  596. GOTO 157
  597. 163 CONTINUE
  598.  
  599. LISOUS(1)=IPT3
  600. SEGDES,IPT3
  601.  
  602. * +------+
  603. * | SEG2 |
  604. * +------+
  605.  
  606. * ON COMMENCE PAR COMPTER LE NOMBRE D'ELEMENTS SEG2 DU CONTOUR
  607. NBELEM=0
  608. DO 241 J=1,ITE
  609. JJ=J
  610. 243 DO 242 I=1,NBCONR
  611. IF (ABS(KON(I,JJ,2)).NE.1) GOTO 242
  612. * On prend bien soin de ne compter les aretes que dans
  613. * un seul sens !
  614. KON1=KON(I,JJ,1)
  615. KON3=KON(I,JJ,3)
  616. IF ((IMOT1.EQ.3.AND.(ABS(KON1).LT.J.OR.KON1*KON3.LE.0))
  617. & .OR.(IMOT1.EQ.2.AND.(-KON1.LT.J.OR.KON3.GT.0))
  618. & .OR.(IMOT1.EQ.1.AND.(KON1.LT.J.OR.KON3.LT.0))) GOTO 242
  619. NBELEM=NBELEM+1
  620. 242 CONTINUE
  621. IF (KON(NBCON,JJ,1).EQ.0) GOTO 241
  622. JJ=KON(NBCON,JJ,1)
  623. GOTO 243
  624. 241 CONTINUE
  625.  
  626. IF (IIMPI.NE.0) WRITE(IOIMP,1111) NBELEM
  627. IF (IERR.NE.0) GOTO 64
  628.  
  629. * CREATION DU CHAPEAU DU SECOND SOUS-MELEME
  630. NBNN=2
  631. NBSOUS=0
  632. NBREF=0
  633. SEGINI,IPT2
  634. IPT2.ITYPEL=NBNN
  635.  
  636. * REMPLISSAGE SELON L'OPTION IMOT1 DEMANDEE (EXTE, INTE, TOUT)
  637. IEL=0
  638.  
  639. * Recherche d'une arete orientee dans le sens +1, pas encore
  640. * ajoutee au contour de SEG2
  641. KAUX=1
  642. 250 K=KAUX
  643. KAUXR=KAUX
  644. 251 DO 252 KL=1,NBCONR
  645. IF (KON(KL,K,2).NE.1) GOTO 252
  646. IT=KON(KL,K,1)
  647. IT3=KON(KL,K,3)
  648. IF ((IMOT1.EQ.1.AND.(IT.LT.0.OR.IT3.LT.0)).OR.
  649. & (IMOT1.EQ.2.AND.(IT.GT.0.OR.IT3.GT.0)).OR.
  650. & (IMOT1.EQ.3.AND.(IT*IT3.LT.0))) GOTO 252
  651. IF (IT.EQ.0) GOTO 253
  652. GOTO 254
  653. 252 CONTINUE
  654. K=KON(NBCON,K,1)
  655. IF (K.NE.0) GOTO 251
  656. 253 KAUX=KAUX+1
  657. IF (KAUX.EQ.ITE+1) GOTO 263
  658. GOTO 250
  659.  
  660. 254 KPRESS=KAUXR
  661. GOTO 255
  662. * Recherche de l'arete SEG2 suivante
  663. 257 KL=1
  664. 255 DO 256 L=KL,NBCONR
  665. M=KON(L,K,1)
  666. IF (M.EQ.0) GOTO 253
  667. M2=KON(L,K,2)
  668. IF (ABS(M2).NE.1) GOTO 256
  669. M3=KON(L,K,3)
  670. IF ((IMOT1.EQ.1.AND.(M.LT.0.OR.M3.LT.0)).OR.
  671. & (IMOT1.EQ.2.AND.(M.GT.0.OR.M3.GT.0)).OR.
  672. & (IMOT1.EQ.3.AND.(M*M3.LT.0))) GOTO 256
  673. GOTO 258
  674. 256 CONTINUE
  675. K=KON(NBCON,K,1)
  676. IF (K.EQ.0) GOTO 253
  677. GOTO 257
  678.  
  679. * Ajout d'un element SEG2 joignant KPRESS a M
  680. 258 IEL=IEL+1
  681. MM=ABS(M)
  682. IPT2.NUM(1,IEL)=IDCP(KPRESS)
  683. IPT2.NUM(NBNN,IEL)=IDCP(MM)
  684. IPT2.ICOLOR(IEL)=ABS(M3)-1
  685.  
  686. * On change le signe de KON(*,*,1) pour indiquer que l'element
  687. * a deja ete ajoute au contour
  688. KON(L,K,1)=-M
  689. * Idem, pour l'arete parcourue en sens inverse...
  690. M1=MM
  691. 259 DO 260 L=1,NBCONR
  692. IF (KON(L,M1,2).NE.-M2) GOTO 260
  693. IF (KON(L,M1,1).EQ.0) GOTO 262
  694. IF (ABS(KON(L,M1,1)).EQ.KPRESS) GOTO 261
  695. 260 CONTINUE
  696. M1=KON(NBCON,M1,1)
  697. IF (M1.EQ.0) GOTO 262
  698. GOTO 259
  699. 261 KON(L,M1,1)=-KON(L,M1,1)
  700. 262 KPRESS=MM
  701. * ...puis on continue de suivre le contour
  702. GOTO 257
  703. 263 CONTINUE
  704.  
  705. LISOUS(2)=IPT2
  706. SEGDES,IPT2
  707.  
  708. SEGDES,MELEME
  709. CALL ECROBJ('MAILLAGE',MELEME)
  710.  
  711. * ON INSCRIT SEULEMENT LE CONTOUR EXTERIEUR DANS LES
  712. * REFERENCES DU MAILLAGE INITIAL
  713. SEGACT,IPT8
  714. IF (IPT8.LISREF(/1).EQ.0.AND.IMOT1.EQ.1) THEN
  715. NBREF=1
  716. NBNN=IPT8.NUM(/1)
  717. NBELEM=IPT8.NUM(/2)
  718. NBSOUS=IPT8.LISOUS(/1)
  719. SEGADJ,IPT8
  720. IPT8.LISREF(1)=MELEME
  721. ENDIF
  722. SEGDES,IPT8
  723. ENDIF
  724.  
  725.  
  726. 64 CONTINUE
  727. SEGSUP,KON,IDCP
  728. RETURN
  729. END
  730.  
  731.  
  732.  

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