Télécharger chanlg.eso

Retour à la liste

Numérotation des lignes :

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

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