Télécharger chanlg.eso

Retour à la liste

Numérotation des lignes :

chanlg
  1. C CHANLG SOURCE FANDEUR 21/04/26 21:15:07 10979
  2. C CE SOUS PROGRAMME FABRIQUE L'ENSEMBLE DES ARETES D'UN MAILLAGE
  3. C IL FONCTIONNE SUIVANT UN PRINCIPE DERIVE DES TRACES
  4. C
  5. SUBROUTINE CHANLG
  6. IMPLICIT INTEGER(I-N)
  7.  
  8. -INC PPARAM
  9. -INC CCOPTIO
  10. -INC CCGEOME
  11. -INC SMELEME
  12. -INC SMCOORD
  13. SEGMENT ICPR(nbpts)
  14. SEGMENT IDCP(ITE)
  15. SEGMENT NTSEG(0)
  16. SEGMENT KON(NBCON,NMAX,3)
  17.  
  18. ICPR = 0
  19. ICDP = 0
  20. KON = 0
  21.  
  22. CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
  23. IF (IERR.NE.0) RETURN
  24.  
  25. SEGINI ICPR
  26. ITE=0
  27. NELTOT=0
  28. idegre=0
  29.  
  30. SEGACT MELEME
  31. IPT8 = MELEME
  32. c on peut faire un ACTOBJ !
  33. NBSOU8 = meleme.LISOUS(/1)
  34. IPT1=MELEME
  35. DO 3 I=1,MAX(1,NBSOU8)
  36. IF (NBSOU8.NE.0) THEN
  37. IPT1 = meleme.LISOUS(I)
  38. SEGACT IPT1
  39. ENDIF
  40. NBNOE1=IPT1.NUM(/1)
  41. NBELT1=IPT1.NUM(/2)
  42. NELTOT=NELTOT+NBELT1
  43. K=IPT1.ITYPEL
  44. idegre=KDEGRE(K)
  45. IDEP=NSPOS(K)
  46. if (idep.eq.0) goto 8
  47. IF (NBSOM(K).GT.0) THEN
  48. IFEP=IDEP+NBSOM(K)-1
  49. ELSE
  50. C Cas du polygone
  51. IFEP=IDEP+NBNOE1-1
  52. ENDIF
  53. DO 4 JJ=IDEP,IFEP
  54. J=IBSOM(JJ)
  55. DO 41 K=1,NBELT1
  56. IPOIT=IPT1.NUM(J,K)
  57. IF (ICPR(IPOIT).NE.0) GOTO 41
  58. ITE=ITE+1
  59. ICPR(IPOIT)=ITE
  60. 41 CONTINUE
  61. 4 CONTINUE
  62. 8 CONTINUE
  63. IF (NBSOU8.NE.0) SEGDES IPT1
  64. 3 CONTINUE
  65. SEGDES MELEME
  66. *
  67. IF (ITE.NE.0) GOTO 6
  68. SEGSUP,ICPR
  69. * sg 2016/11/29 gestion maillage vide
  70. IF (NELTOT.EQ.0) THEN
  71. * Par défaut SEG2, sinon en fonction du dernier KDEGRE lu.
  72. ity=2
  73. IF (idegre.ge.1.and.idegre.le.3) ity=idegre
  74. CALL melvid(ity,meleme)
  75. CALL ECROBJ('MAILLAGE',MELEME)
  76. ELSE
  77. * 16 2
  78. *Type d'élément incorrect
  79. CALL ERREUR(16)
  80. ENDIF
  81. RETURN
  82. 6 CONTINUE
  83.  
  84. C ITE EST LE NOMBRE DE POINTS A CONSIDERER ICPR LE TABLEAU
  85. C ON VA MAINTENANT INITIALISER ET REMPLIR LE TABLEAU DES CONNECTIONS
  86. NBCON=7
  87. NBCONR=NBCON-1
  88. NMAX= 10*ITE
  89. SEGINI KON
  90. C FABRICATION DU TABLEAU DES CONNECTIONS
  91. C 1 POINT FINAL
  92. C 2 POINT INTERMEDIAIRE EVENTUEL ET SENS
  93. ICHAIN=ITE
  94. SEGACT MELEME
  95. IOO=0
  96. IA=0
  97. IPT1=MELEME
  98. DO 30 IO=1,MAX(1,NBSOU8)
  99. IF (NBSOU8.NE.0) IPT1=LISOUS(IO)
  100. SEGACT IPT1
  101. K=IPT1.ITYPEL
  102. If ((K.eq.22).or.(K.eq.48)) then
  103. segdes ipt1
  104. goto 30
  105. endif
  106. NBNN=KDEGRE(K)
  107. c k=32 et nbnn=2
  108. IF (IA.EQ.0) IA=NBNN
  109. IF (NBNN.NE.IA) THEN
  110. * PRINT *,'*MAILLAGE IMPOSSIBLE'
  111. * PRINT *,'*EXISTENCE D''ELEMENTS DONNANT'
  112. * PRINT *,'*DES SEG2 ET DES SEG3'
  113. CALL ERREUR(26)
  114. GOTO 64
  115. ENDIF
  116. IPAS=NBNN-1
  117. KKK=LTEL(1,K)
  118. c IPAS = 1 & KKK = 1
  119. * Cas des segments
  120. IF (KKK.EQ.0) THEN
  121. DO 122 I=1,IPT1.NUM(/2)
  122. NMIL=1
  123. N1=ICPR(IPT1.NUM(1,I))
  124. JSUIV=1+IPAS
  125. N2=ICPR(IPT1.NUM(JSUIV,I))
  126. IF (N1*N2.EQ.0) THEN
  127. CALL ERREUR(26)
  128. GOTO 64
  129. ENDIF
  130. IF (IPAS.EQ.2) NMIL=IPT1.NUM(1+1,I)
  131. NI=N1
  132. NJ=N2
  133. KSCOL=IPT1.ICOLOR(I)
  134. * PRINT *,'*KSCOL',KSCOL
  135. IPO=0
  136. 123 CONTINUE
  137. DO 125 IK=1,NBCONR
  138. IF (KON(IK,NI,1).EQ.0) GOTO 126
  139. IF (KON(IK,NI,1).EQ.NJ) GOTO 129
  140. 125 CONTINUE
  141. IF (KON(NBCON,NI,1).EQ.0) GOTO 128
  142. NI=KON(NBCON,NI,1)
  143. GOTO 123
  144. 126 CONTINUE
  145. KON(IK,NI,1)=NJ
  146. KON(IK,NI,2)=NMIL
  147. KON(IK,NI,3)=KSCOL
  148. GOTO 129
  149. 128 ICHAIN=ICHAIN+1
  150. IF (ICHAIN.GE.NMAX) THEN
  151. CALL ERREUR(26)
  152. GOTO 64
  153. ENDIF
  154. KON(NBCON,NI,1)=ICHAIN
  155. IK=1
  156. NI=ICHAIN
  157. GOTO 126
  158. 129 CONTINUE
  159. IF (IPO.EQ.1) GOTO 122
  160. NMIL=-NMIL
  161. NI=N2
  162. NJ=N1
  163. IPO=1
  164. GOTO 123
  165. 122 CONTINUE
  166. ELSE
  167. IOO=1
  168. KK=LTEL(2,K)-1
  169. c KKK = 1 && KK = 49
  170. DO 300 III=1,KKK
  171. C ****BOUCLE PERMETTANT D'ALLER RECHERCHER TOUTES LES FACES
  172. KK=KK+1
  173. ITYP=LDEL(1,KK)
  174. IDEP=LDEL(2,KK)
  175. IF (K.EQ.32) ITYP = 0
  176. IF (ITYP.GT.0) THEN
  177. IFEP=IDEP+KDFAC(1,ITYP)-1
  178. * SG 20160711 pour les faces TRI7 et QUA9, on ignore le dernier
  179. * point (centre de la face)
  180. IF (ITYP.EQ.7.OR.ITYP.EQ.8) IFEP=IFEP-1
  181. ELSE
  182. C Cas du polygone
  183. IFEP= IDEP+IPT1.NUM(/1)-1
  184. ENDIF
  185. DO 22 I=1,IPT1.NUM(/2)
  186. KSCOL=IPT1.ICOLOR(I)
  187. DO 221 J=IDEP,IFEP,IPAS
  188. NMIL=1
  189. N1=ICPR(IPT1.NUM(LFAC(J),I))
  190. JSUIV=J+IPAS
  191. IF (JSUIV.GT.IFEP) JSUIV=IDEP
  192. N2=ICPR(IPT1.NUM(LFAC(JSUIV),I))
  193. IF (IPAS.EQ.2) NMIL=IPT1.NUM(LFAC(J+1),I)
  194. NI=N1
  195. NJ=N2
  196. IF (N1*N2.EQ.0) THEN
  197. CALL ERREUR(26)
  198. GOTO 64
  199. ENDIF
  200. IPO=0
  201. 23 CONTINUE
  202. DO 25 IK=1,NBCONR
  203. IF (KON(IK,NI,1).EQ.0) GOTO 26
  204. IF (KON(IK,NI,1).EQ.NJ) GOTO 29
  205. 25 CONTINUE
  206. IF (KON(NBCON,NI,1).EQ.0) GOTO 28
  207. NI=KON(NBCON,NI,1)
  208. GOTO 23
  209. 26 KON(IK,NI,1)=NJ
  210. KON(IK,NI,2)=NMIL
  211. KON(IK,NI,3)=KSCOL
  212. GOTO 29
  213. 28 ICHAIN=ICHAIN+1
  214. IF (ICHAIN.GE.NMAX) THEN
  215. CALL ERREUR(26)
  216. GOTO 64
  217. ENDIF
  218. KON(NBCON,NI,1)=ICHAIN
  219. IK=1
  220. NI=ICHAIN
  221. GOTO 26
  222. 29 IF (IPO.EQ.1) GOTO 221
  223. NMIL=-NMIL
  224. NI=N2
  225. NJ=N1
  226. IPO=1
  227. GOTO 23
  228. 221 CONTINUE
  229. 22 CONTINUE
  230. 300 CONTINUE
  231. ENDIF
  232. IF (NBSOU8.NE.0) SEGDES IPT1
  233. 30 CONTINUE
  234.  
  235. IF (IIMPI.EQ.2)WRITE (IOIMP,1122) (((KON(I,J,K),K=1
  236. $ ,2),I=1,NBCON),J=1,NMAX)
  237. 1122 FORMAT(1X,14I5)
  238.  
  239. SEGDES MELEME
  240.  
  241. SEGINI IDCP
  242.  
  243. DO 40 I=1,ICPR(/1)
  244. IF (ICPR(I).EQ.0) GOTO 40
  245. IDCP(ICPR(I))=I
  246. 40 CONTINUE
  247.  
  248. ************************************************************************
  249. * CREATION DE L'OBJET MAILLAGE
  250. NBSOUS=0
  251. NBREF=0
  252. NBELEM=0
  253.  
  254. C ****ON COMPTE LE NOMBRE D'ELEMENTS POUR ACTIVER LE SEGMENT
  255.  
  256. DO 170 J=1,ITE
  257. JJ=J
  258.  
  259. 179 CONTINUE
  260. DO 180 I=1,NBCONR
  261. M=KON(I,JJ,1)
  262. IF(M.LT.J) GOTO 180
  263. NBELEM=NBELEM+1
  264. 180 CONTINUE
  265.  
  266. IF (KON(NBCON,JJ,1) .EQ. 0) GOTO 170
  267. JJ=KON(NBCON,JJ,1)
  268. GOTO 179
  269. 170 CONTINUE
  270.  
  271. ** TEST VERIFIANT SI AU DEPART ON A DEJA DES POINTS,SEG2 OU SEG3
  272. IF (IOO.EQ.0) THEN
  273. * LE MAILLAGE EXISTE DEJA
  274. * PRINT *,'*LE MAILLAGE EXISTE DEJA'
  275. CALL ECROBJ('MAILLAGE',IPT1)
  276. GOTO 64
  277. ENDIF
  278.  
  279. IF (NBELEM.EQ.0) THEN
  280. CALL ERREUR(26)
  281. GOTO 64
  282. ENDIF
  283.  
  284. C****ETABLISSEMENT DU MAILLAGE
  285. C****CONSTRUCTION DU TABLEAU NUM
  286. SEGINI,MELEME
  287. ITYPEL=NBNN
  288. IEL=0
  289. DO 100 J=1,ITE
  290. JJ=J
  291. 109 CONTINUE
  292. DO 110 I=1,NBCONR
  293. M=KON(I,JJ,1)
  294. IF (M.LT.J) GOTO 110
  295. IEL=IEL+1
  296. NUM(1,IEL)=IDCP(J)
  297. NUM(NBNN,IEL)=IDCP(M)
  298. ICOLOR(IEL)=KON(I,JJ,3)
  299. IF (NBNN.EQ.3) NUM(2,IEL)=ABS(KON(I,JJ,2))
  300. 110 CONTINUE
  301.  
  302. IF (KON(NBCON,JJ,1).EQ.0) GOTO 100
  303. JJ=KON(NBCON,JJ,1)
  304. GOTO 109
  305. 100 CONTINUE
  306.  
  307. SEGDES MELEME
  308. CALL ECROBJ('MAILLAGE',MELEME)
  309.  
  310. * ON INSCRIT LE MAILLAGE DANS LE MAILLAGE INITIAL
  311. * SEGACT,IPT8*MOD
  312. * IF (IPT8.LISREF(/1).EQ.0) THEN
  313. * NBREF=1
  314. * NBNN=IPT8.NUM(/1)
  315. * NBELEM=IPT8.NUM(/2)
  316. * NBSOUS=IPT8.LISOUS(/1)
  317. * SEGADJ IPT8
  318. * IPT8.LISREF(1)=MELEME
  319. * ENDIF
  320. * SEGDES IPT8
  321.  
  322. 64 CONTINUE
  323. IF (KON.GT.0) SEGSUP,KON
  324. IF (IDCP.GT.0) SEGSUP,IDCP
  325. IF (ICPR.GT.0) SEGSUP,ICPR
  326. c CALL ACTOBJ pour meleme=ipt8
  327. SEGDES,IPT8
  328.  
  329. RETURN
  330. END
  331.  
  332.  
  333.  

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