Télécharger chanlg.eso

Retour à la liste

Numérotation des lignes :

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

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