Télécharger impos8.eso

Retour à la liste

Numérotation des lignes :

  1. C IMPOS8 SOURCE FANDEUR 11/04/12 21:16:14 6938
  2.  
  3. subroutine impos8
  4.  
  5. IMPLICIT INTEGER(I-N)
  6. IMPLICIT REAL*8 (A-H,O-Z)
  7.  
  8. -INC CCOPTIO
  9. -INC SMCOORD
  10. -INC SMELEME
  11. *
  12. SEGMENT icpr(nnoe)
  13. *
  14. PARAMETER ( X1s3 = 0.333333333333333333333333333333333333333333 ,
  15. & X1s2 = 0.5 )
  16. *
  17. character*4 mcle(1)
  18. data mcle /'ESCL'/
  19. *
  20. * lecture des deux maillages :
  21. * 1er = ligne (MAITRE), 2eme = ligne ou point (ESCLAVE)
  22. *
  23. ipt1 = 0
  24. ipt2 = 0
  25. ippr = 0
  26. icas = 1
  27. *
  28. call lirobj('MAILLAGE',ipt1,1,iretou)
  29. if (ierr.ne.0) return
  30. call lirmot(mcle,1,ire,0)
  31. if (ire.eq.0) then
  32. call erreur(852)
  33. return
  34. endif
  35. call lirobj('MAILLAGE',ipt2,0,iretou)
  36. if (ierr.ne.0) return
  37. if (iretou.eq.0) then
  38. call lirobj('POINT ',ippr,1,iretou)
  39. if (ierr.ne.0) return
  40. ipt2 = ippr
  41. call crelem(ipt2)
  42. endif
  43. *
  44. segact ipt1,ipt2
  45. *
  46. nbel1 = ipt1.num(/2)
  47. nbno1 = ipt1.num(/1)
  48. nbel2 = ipt2.num(/2)
  49. nbno2 = ipt2.num(/1)
  50. *
  51. * Quelques verifications :
  52. if (ipt1.itypel.ne.2) call erreur(853)
  53. if (ipt2.itypel.eq.1) then
  54. icas = 2
  55. if (nbel2.ne.1) call erreur(976)
  56. else
  57. if (ipt2.itypel.ne.2) call erreur(853)
  58. endif
  59. if (ierr.ne.0) goto 9000
  60. *
  61. * Quelques initialisations :
  62. idimp1 = idim+1
  63. nnoe = xcoor(/1) / idimp1
  64. *
  65. nbeele = 0
  66. nbepts = nnoe
  67. nbecoo = (nbepts-1) * idimp1
  68. *
  69. * Branchement en fonction du cas a traiter (variable icas) :
  70. GOTO (1000,2000), icas
  71. call erreur(5)
  72. goto 9000
  73. *
  74. * --------
  75. * icas = 1 -> MAITRE = ligne (SEG2), ESCLAVE = ligne (SEG2)
  76. * --------
  77. * Remarque : nbno2 = nbno1 = 2
  78. *
  79. 1000 CONTINUE
  80. *
  81. * estimation du nombre maximal d elements a creer
  82. *
  83. segini icpr
  84. do 100 i=1, nbel1
  85. icpr(ipt1.num(1,i)) = 1
  86. icpr(ipt1.num(2,i)) = 1
  87. 100 continue
  88. do 101 i=1,nbel2
  89. ipv = ipt2.num(1,i)
  90. if (icpr(ipv).eq.1 .or. icpr(ipv).eq.3) then
  91. icpr(ipv) = 3
  92. else
  93. icpr(ipv) = 2
  94. endif
  95. ipv = ipt2.num(2,i)
  96. if (icpr(ipv).eq.1 .or. icpr(ipv).eq.3) then
  97. icpr(ipv) = 3
  98. else
  99. icpr(ipv) = 2
  100. endif
  101. 101 continue
  102. ipo1 = 0
  103. ipo2 = 0
  104. ipo3 = 0
  105. do 102 i = 1, nnoe
  106. if (icpr(i).eq.1) then
  107. ipo1 = ipo1 + 1
  108. elseif (icpr(i).eq.2) then
  109. ipo2 = ipo2 + 1
  110. elseif (icpr(i).eq.3) then
  111. ipo3 = ipo3 + 1
  112. endif
  113. 102 continue
  114. * ipo1m = ipo1 + ipo3
  115. ipo2m = ipo2 + ipo3
  116. nblag = ipo2m * nbel1
  117. segsup icpr
  118. *
  119. * Creation du meleme associe a la relation
  120. * 1 point support a creer pour chaque element genere
  121. *
  122. nbelem = nblag
  123. nbnn = 4
  124. nbsous = 0
  125. nbref = 0
  126. segini,meleme
  127. itypel=22
  128. *
  129. nbpts = nnoe + nblag
  130. segadj mcoord
  131. *
  132. * Boucle sur les elements du 1er maillage (ligne maitre)
  133. *
  134. do 110 iel = 1, nbel1
  135. *
  136. nbeini = nbeele
  137. *
  138. * 1er noeud maitre
  139. *
  140. ip1 = ipt1.num(1,iel)
  141. ipv = (ip1-1)*idimp1
  142. xp1 = xcoor(ipv+1)
  143. yp1 = xcoor(ipv+2)
  144. *
  145. * 2eme noeud maitre dans
  146. *
  147. ip2 = ipt1.num(2,iel)
  148. ipv = (ip2-1)*idimp1
  149. xp2 = xcoor(ipv+1)
  150. yp2 = xcoor(ipv+2)
  151. *
  152. * Boucle sur les points du 2eme maillage (ligne esclave)
  153. *
  154. do 120 jel = 1, nbel2
  155. do 120 jno = 1, nbno2
  156. *
  157. * noeud esclave
  158. *
  159. jp = ipt2.num(jno,jel)
  160. *
  161. * verification que pas relation du noeud esclave sur lui meme
  162. *
  163. if (jp.eq.ip1) goto 120
  164. if (jp.eq.ip2) goto 120
  165. *
  166. * verification que pas deja la relation
  167. *
  168. do 121 irela = nbeini+1, nbeele
  169. if (jp.eq.num(4,irela)) goto 120
  170. 121 continue
  171. *
  172. ipv = (jp-1) * idimp1
  173. xp = xcoor(ipv+1)
  174. yp = xcoor(ipv+2)
  175. *
  176. * xcoor : points supports des mult. et rangement ds melem
  177. *
  178. nbeele = nbeele + 1
  179. nbepts = nbepts + 1
  180. nbecoo = nbecoo + idimp1
  181. *
  182. xcoor(nbecoo+1) = (xp1+xp2+xp) * X1s3
  183. xcoor(nbecoo+2) = (yp1+yp2+yp) * X1s3
  184. xcoor(nbecoo+3) =0.
  185.  
  186. num(1,nbeele) = nbepts
  187. num(2,nbeele) = ip1
  188. num(3,nbeele) = ip2
  189. num(4,nbeele) = jp
  190. *
  191. 120 continue
  192. *
  193. 110 continue
  194. *
  195. GOTO 3000
  196. *
  197. * --------
  198. * icas = 2 -> MAITRE = ligne (SEG2), ESCLAVE = 1 seul point
  199. * --------
  200. * Remarque : nbno2 = 1, nbno1 = 2
  201. *
  202. 2000 CONTINUE
  203. *
  204. * estimation du nombre maximal d elements a creer
  205. *
  206. nblag = nbel1 + 1
  207. *
  208. * Creation du meleme associe a la relation
  209. * 1 point support a creer pour chaque element genere
  210. *
  211. nbelem = nblag
  212. nbnn = 3
  213. nbsous = 0
  214. nbref = 0
  215. segini,meleme
  216. itypel = 22
  217. *
  218. nbpts = nnoe + nblag
  219. segadj mcoord
  220. *
  221. * noeud esclave
  222. *
  223. jp = ipt2.num(1,1)
  224. ipv = (jp-1)*idimp1
  225. xp = xcoor(ipv+1)
  226. yp = xcoor(ipv+2)
  227. *
  228. * Boucle sur les noeuds du 1er maillage (ligne maitre)
  229. *
  230. do 210 iel = 1, nbel1 + 1
  231. *
  232. nbeini = nbeele
  233. *
  234. * 1er noeud maitre
  235. *
  236. if (iel.gt.nbel1) then
  237. ip1=ipt1.num(2,nbel1)
  238. else
  239. ip1=ipt1.num(1,iel)
  240. endif
  241. ipv = (ip1-1) * idimp1
  242. *
  243. * verification que pas relation du noeud esclave sur lui meme
  244. if (jp.eq.ip1) goto 210
  245. *
  246. * verification que pas deja la relation
  247. do 220 irela = nbeini+1,nbeele
  248. if (jp.eq.num(3,irela)) goto 210
  249. 220 continue
  250. *
  251. xp1 = xcoor(ipv+1)
  252. yp1 = xcoor(ipv+2)
  253. *
  254. * xcoor : points supports des mult. et rangement ds melem
  255. *
  256. nbeele = nbeele + 1
  257. nbepts = nbepts + 1
  258. nbecoo = nbecoo + idimp1
  259. *$
  260. xcoor(nbecoo+1) = (xp1+xp) * X1s2
  261. xcoor(nbecoo+2) = (yp1+yp) * X1s2
  262. xcoor(nbecoo+3) =0.
  263. *
  264. num(1,nbeele) = nbepts
  265. num(2,nbeele) = ip1
  266. num(3,nbeele) = jp
  267. *
  268. 210 continue
  269. *
  270. * GOTO 3000
  271. *
  272. * -----------------
  273. * Fin du traitement
  274. * -----------------
  275. 3000 CONTINUE
  276. * Ajustement au plus juste de meleme et mcoord
  277. if (nbelem.lt.nbeele) then
  278. call erreur(5)
  279. segsup,meleme
  280. goto 9000
  281. elseif (nbelem.gt.nbeele) then
  282. nbelem=nbeele
  283. segadj meleme
  284. nbpts = nbepts
  285. segadj mcoord
  286. endif
  287. segdes,meleme
  288. call ecrobj('MAILLAGE',meleme)
  289. 9000 CONTINUE
  290. segdes,ipt1,ipt2
  291. if (ippr.ne.0) segsup,ipt2
  292.  
  293. return
  294. end
  295.  
  296.  
  297.  

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