Télécharger inclu3.eso

Retour à la liste

Numérotation des lignes :

  1. C INCLU3 SOURCE JC220346 16/11/22 21:15:10 9199
  2.  
  3. SUBROUTINE INCLU3(IPT1,IPT2)
  4.  
  5. IMPLICIT INTEGER(I-N)
  6. IMPLICIT REAL*8(A-H,O-Z)
  7.  
  8. -INC CCOPTIO
  9. -INC SMELEME
  10. -INC SMCOORD
  11.  
  12. SEGMENT ICPR(NNNOE)
  13. SEGMENT IELOP(IN)
  14.  
  15. CHARACTER*4 LEMOT(3),LEMO2(1)
  16. DATA LEMOT / 'STRI','LARG','BARY' /
  17. DATA LEMO2 / 'NOID' /
  18.  
  19. C* IF (IDIM.NE.3) THEN
  20. C* INTERR(1)=IDIM
  21. C* CALL ERREUR(709)
  22. C* RETURN
  23. C* ENDIF
  24. IDIMP1=IDIM+1
  25.  
  26. CALL LIRMOT(LEMOT,3,IMSLU,0)
  27. IF (IMSLU.EQ.0) IMSLU=1
  28.  
  29. IVERI=0
  30. CALL LIRMOT(LEMO2,1,IRE2,0)
  31. IF (IRE2.EQ.1) IVERI=1
  32.  
  33. C CRITERE D'INCLUSION :
  34. CALL LIRREE(XCRITT,0,IRET)
  35. IF (IRET.EQ.0) XCRITT=1.E-2
  36.  
  37. SEGACT,IPT1,IPT2
  38. IPT1IN=IPT1
  39. IPT2IN=IPT2
  40.  
  41. * Conversion de IPT1 en maillage de type POI1
  42. * ---------------------------------------------
  43. NBPTSI=XCOOR(/1)/IDIMP1
  44. IF (IPT1.ITYPEL .EQ. 1) THEN
  45. IF (IMSLU.EQ.3) IPT5=IPT1
  46. ELSE
  47. C* Traitement de l'option 'BARY' :
  48. C* IPT1 contiendra les centres de gravite de IPT1 (dans le meme ordre)
  49. IF (IMSLU.EQ.3) THEN
  50. NBPTS=NBPTSI
  51. NBNN=1
  52. NBELEM=0
  53. NBREF=0
  54. NBSOUS=0
  55. SEGINI,IPT5
  56. IPT5.ITYPEL=1
  57. IGRAV=NBPTSI
  58. IPT6=IPT1
  59. NSOU1=IPT6.LISOUS(/1)
  60. DO i=1,MAX(1,NSOU1)
  61. IF (NSOU1.NE.0) THEN
  62. IPT6=IPT1.LISOUS(i)
  63. SEGACT,IPT6
  64. ENDIF
  65. NBELE5=NBELEM
  66. NBELE1=IPT6.NUM(/2)
  67. NBELEM=NBELEM+NBELE1
  68. SEGADJ,IPT5
  69. NBPTS=NBPTS+NBELE1
  70. SEGADJ,MCOORD
  71. NBN1=IPT6.NUM(/1)
  72. DO j=1,NBELE1
  73. IGRAV=IGRAV+1
  74. IPT5.NUM(1,NBELE5+j)=IGRAV
  75. XP=0.D0
  76. YP=0.D0
  77. ZP=0.D0
  78. DO k=1,NBN1
  79. IREF=IPT6.NUM(k,j)*IDIMP1-IDIM
  80. XP=XCOOR(IREF) +XP
  81. YP=XCOOR(IREF+1)+YP
  82. ZP=XCOOR(IREF+2)+ZP
  83. ENDDO
  84. IREF=IGRAV*IDIMP1-IDIM
  85. XCOOR(IREF )=XP/FLOAT(NBN1)
  86. XCOOR(IREF+1)=YP/FLOAT(NBN1)
  87. XCOOR(IREF+2)=ZP/FLOAT(NBN1)
  88. ENDDO
  89. IF (NSOU1.NE.0) SEGDES,IPT6
  90. ENDDO
  91. SEGDES,IPT1
  92. IPT1=IPT5
  93. C* Traitement des options 'STRI' et 'LARG'
  94. ELSE
  95. CALL CHANGE(IPT1,1)
  96. ENDIF
  97. ENDIF
  98. NNNOE=IPT1.NUM(/2)
  99. *
  100. * Conversion de ipt2 en elements de type TET4
  101. *
  102. IF (IPT2.LISOUS(/1).NE.0) THEN
  103. IN=IPT2.LISOUS(/1)
  104. SEGINI IELOP
  105. NBELEM=0
  106. DO 36 I=1,IPT2.LISOUS(/1)
  107. MELEME=IPT2.LISOUS(I)
  108. SEGACT MELEME
  109. IF (MELEME.ITYPEL.NE.23) THEN
  110. CALL CHANGE(MELEME,23)
  111. * write(6,*) ' inclu3 conv faite'
  112. ENDIF
  113. NBELEM=NBELEM+NUM(/2)
  114. IELOP(I)=MELEME
  115. 36 CONTINUE
  116. NBNN=4
  117. NBREF=0
  118. NBSOUS=0
  119. SEGINI IPT3
  120. IA=0
  121. DO 37 I=1,IPT2.LISOUS(/1)
  122. MELEME=IELOP(I)
  123. DO 38 J=1,NUM(/2)
  124. DO 38 K=1,NUM(/1)
  125. IPT3.NUM(K,J+IA) = NUM(K,J)
  126. 38 CONTINUE
  127. IA=IA+NUM(/2)
  128. SEGDES MELEME
  129. 37 CONTINUE
  130. IPT3.ITYPEL=23
  131. IPT2=IPT3
  132. ELSE
  133. IF (IPT2.ITYPEL.NE.23) THEN
  134. CALL CHANGE (IPT2,23)
  135. * write(6,*) ' inclu3 conv faite'
  136. ENDIF
  137. ENDIF
  138.  
  139. CALL INCLU4(IPT1,IPT2,ICPR,XCRITT)
  140. * write(6,FMT='(10i6)') (ICPR(IU),IU=1,ICPR(/1))
  141. IF (IERR.NE.0) GOTO 999
  142.  
  143. C TEST ET CREATION DU SEGMENT RESULTAT
  144. NBREF=0
  145. MELEME=IPT1IN
  146. SEGACT MELEME
  147. IPT2=MELEME
  148. NBSOU=LISOUS(/1)
  149. IF (NBSOU.NE.0) THEN
  150. NBNN=0
  151. NBELEM=0
  152. NBSOUS=NBSOU
  153. SEGINI IPT8
  154. ISO=0
  155. ENDIF
  156. IF (IMSLU.EQ.3) THEN
  157. NBELE5=0
  158. SEGACT,IPT5
  159. ENDIF
  160. DO 270 ISOUS=1,MAX(1,NBSOU)
  161. IF (NBSOU.NE.0) THEN
  162. IPT2=LISOUS(ISOUS)
  163. SEGACT IPT2
  164. ENDIF
  165. NBNN=IPT2.NUM(/1)
  166. NBELEM=IPT2.NUM(/2)
  167. ICOUNT=0
  168. DO 250 IEL=1,NBELEM
  169. IF (IMSLU.EQ.1) THEN
  170. DO 251 INOEU=1,NBNN
  171. IF (ICPR(IPT2.NUM(INOEU,IEL)).EQ.0) GOTO 250
  172. 251 CONTINUE
  173. ICOUNT=ICOUNT+1
  174. ELSE IF (IMSLU.EQ.2) THEN
  175. DO 252 INOEU=1,NBNN
  176. IF (ICPR(IPT2.NUM(INOEU,IEL)).NE.0) GOTO 253
  177. 252 CONTINUE
  178. GOTO 250
  179. 253 CONTINUE
  180. ICOUNT=ICOUNT+1
  181. C* ELSE IF (IMSLU.EQ.3) THEN
  182. ELSE
  183. IF (ICPR(IPT5.NUM(1,NBELE5+IEL)).NE.0) ICOUNT=ICOUNT+1
  184. ENDIF
  185. 250 CONTINUE
  186. NBSOUS=0
  187. NBREF=0
  188. NBEL=NBELEM
  189. NBELEM=ICOUNT
  190. ICOUNT=1
  191. IF (NBELEM.EQ.0) GOTO 260
  192. SEGINI IPT3
  193. IPT3.ITYPEL=IPT2.ITYPEL
  194. DO 255 IEL=1,NBEL
  195. IF (IMSLU.EQ.1) THEN
  196. DO 256 INOEU=1,NBNN
  197. IF (ICPR(IPT2.NUM(INOEU,IEL)).EQ.0) GOTO 255
  198. IPT3.NUM(INOEU,ICOUNT)=IPT2.NUM(INOEU,IEL)
  199. 256 CONTINUE
  200. IPT3.ICOLOR(ICOUNT)=IPT2.ICOLOR(IEL)
  201. ICOUNT=ICOUNT+1
  202. IF (ICOUNT.GT.NBELEM) GOTO 260
  203. ELSE IF (IMSLU.EQ.2) THEN
  204. IOOK=0
  205. DO 257 INOEU=1,NBNN
  206. IF (ICPR(IPT2.NUM(INOEU,IEL)).NE.0) IOOK=1
  207. IPT3.NUM(INOEU,ICOUNT)=IPT2.NUM(INOEU,IEL)
  208. 257 CONTINUE
  209. IF (IOOK.EQ.0) GOTO 255
  210. IPT3.ICOLOR(ICOUNT)=IPT2.ICOLOR(IEL)
  211. ICOUNT=ICOUNT+1
  212. IF (ICOUNT.GT.NBELEM) GOTO 260
  213. C* ELSE IF (IMSLU.EQ.3) THEN
  214. ELSE
  215. IF (ICPR(IPT5.NUM(1,NBELE5+IEL)).NE.0) THEN
  216. DO INOEU=1,NBNN
  217. IPT3.NUM(INOEU,ICOUNT)=IPT2.NUM(INOEU,IEL)
  218. ENDDO
  219. IPT3.ICOLOR(ICOUNT)=IPT2.ICOLOR(IEL)
  220. ICOUNT=ICOUNT+1
  221. IF (ICOUNT.GT.NBELEM) GOTO 260
  222. ENDIF
  223. ENDIF
  224. 255 CONTINUE
  225.  
  226. * Bilan et sauvegarde
  227.  
  228. 260 CONTINUE
  229. IF (NBSOU.EQ.0) THEN
  230. IF (NBELEM.EQ.0) THEN
  231. IF (IVERI.EQ.1) THEN
  232. * Ecriture d'un maillage vide
  233. NBSOUS=0
  234. NBREF=0
  235. NBNN=0
  236. NBELEM=0
  237. SEGINI IPT4
  238. CALL ECROBJ('MAILLAGE',IPT4)
  239. GOTO 999
  240. ELSE
  241. * Tache impossible. Probablement données erronées
  242. CALL ERREUR(26)
  243. RETURN
  244. ENDIF
  245. ENDIF
  246. GOTO 280
  247. ENDIF
  248. IF (IMSLU.EQ.3) NBELE5=NBELE5+NBEL
  249. IF (NBELEM.NE.0) THEN
  250. IPT8.LISOUS(ISOUS)=IPT3
  251. ISO=ISO+1
  252. SEGDES IPT3
  253. ENDIF
  254. 270 CONTINUE
  255.  
  256. IF (ISO.EQ.1) THEN
  257. SEGSUP IPT8
  258. GOTO 280
  259. ENDIF
  260. IF (ISO.EQ.0) THEN
  261. SEGSUP IPT8
  262. IF (IVERI.EQ.1) THEN
  263. * Ecriture d'un maillage vide
  264. NBSOUS=0
  265. NBREF=0
  266. NBNN=0
  267. NBELEM=0
  268. SEGINI IPT4
  269. CALL ECROBJ('MAILLAGE',IPT4)
  270. GOTO 999
  271. ELSE
  272. * Tache impossible. Probablement données erronées
  273. CALL ERREUR(26)
  274. RETURN
  275. ENDIF
  276. ENDIF
  277. IPT3=IPT8
  278. IF (ISO.EQ.NBSOU) GOTO 280
  279. NBSOUS=ISO
  280. NBREF=0
  281. NBNN=0
  282. NBELEM=0
  283. SEGINI IPT4
  284. ISO=0
  285. DO 275 IS=1,NBSOU
  286. IF (IPT3.LISOUS(IS).EQ.0) GOTO 275
  287. ISO=ISO+1
  288. IPT4.LISOUS(ISO)=IPT3.LISOUS(IS)
  289. 275 CONTINUE
  290. IF (ISO.EQ.0) THEN
  291. NBSOUS=0
  292. NBREF=0
  293. NBNN=0
  294. NBELEM=0
  295. SEGINI IPT4
  296. CALL ECROBJ('MAILLAGE',IPT4)
  297. GOTO 999
  298. ENDIF
  299. SEGSUP IPT3
  300. IPT3=IPT4
  301. 280 CONTINUE
  302. SEGDES IPT3
  303. CALL ECROBJ('MAILLAGE',IPT3)
  304.  
  305. 999 CONTINUE
  306. *** IF (IPT1IN.NE.IPT1) SEGSUP,IPT1
  307. SEGSUP,ICPR
  308. IPT1=IPT1IN
  309. IPT2=IPT2IN
  310. SEGDES,IPT1,IPT2
  311. IF (IMSLU.EQ.3) THEN
  312. NBPTS=NBPTSI
  313. SEGADJ,MCOORD
  314. ENDIF
  315.  
  316. RETURN
  317. END
  318.  
  319.  
  320.  
  321.  
  322.  
  323.  
  324.  
  325.  
  326.  

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