Télécharger envel1.eso

Retour à la liste

Numérotation des lignes :

  1. C ENVEL1 SOURCE CB215821 19/08/20 21:17:02 10287
  2. * copier sur envvol avec gestion du chamelem de valeurs associes
  3. * utilise dans trac cham
  4. C
  5. C SG 2016/07/20 Programmation comme faced2, envvo2 pour gerer les faces TRI7/QUA9
  6. *
  7. SUBROUTINE ENVEL1(MELEME,MELRES,mcoup)
  8. IMPLICIT INTEGER(I-N)
  9. IMPLICIT REAL*8 (A-H,O-Z)
  10.  
  11.  
  12. -INC CCOPTIO
  13. -INC SMELEME
  14. -INC CCGEOME
  15. -INC SMCHAML
  16. *
  17. * Type de faces prises en compte: T3, Q4, T6, Q8, T7, Q9
  18. * Numero dans KDFAC 1 2 3 4 7 8
  19. * Pour ne pas se prendre la tête, on numerote pareil que KDFAC
  20. * Pour les 5 (non utilisé), 6 (polygone) et >8, ca restera à 0
  21. * NTYFAC=20, codé en dur dans CCGEOME pour KDFAC
  22. PARAMETER (NTYFAC=20)
  23. * Nb de faces de chaque type, sert également de compteur
  24. SEGMENT NBFAC(NTYFAC)
  25. * Tableau d'index de début fin dans les tableaux ???(NFAC)
  26. SEGMENT IDXFAC(NTYFAC+1)
  27. * Pointeurs sur des segments MELEME et MELVAL par type de face
  28. SEGMENT IPTFAC(NTYFAC)
  29. SEGMENT MLVFAC(NTYFAC)
  30. * Un segment pointant sur les IFACI et les XFACI
  31. SEGMENT IPOFAC(2,NTYFAC)
  32. * Segment IFACI contenant les noeuds, la couleur et si la face d'un
  33. * type donné est vue ou non
  34. SEGMENT IFACI(NNODE+2,NFACI)
  35. * Segment XFACI contenant les coordonnees noeuds, la couleur et si la face d'un
  36. * type donné est vue ou non
  37. SEGMENT XFACI(NNODE,NFACI)
  38. *
  39. SEGMENT IPPOL(NTPOL)
  40. SEGMENT IPREF(NTPOL)
  41. SEGMENT NTFAC(NFAC)
  42. SEGMENT KFAK(NFAC)
  43. SEGMENT NAUX(max(2,NFAC))
  44. *SG
  45. * Logique loquaf : pour les faces TRI7 et QUA9, normalement, le
  46. * dernier noeud de la face est unique à la face : il peut donc
  47. * servir de clé de hachage et on peut éviter de vérifier l'égaliteé
  48. * de tous les autres noeuds lorsque l'on teste l'égalité des faces.
  49. * C'est ce qu'on fait si loquaf=vrai.
  50. *
  51. LOGICAL LOQUAF,LOPT
  52. PARAMETER (LOQUAF=.TRUE.)
  53. * Pour chaque face dans KDFAC, le numéro d'élément associé
  54. * Ne se trouve pas dans CCGEOME, etonnant
  55. INTEGER ITYEL(NTYFAC)
  56. * T3, Q4, T6, Q8, ? , POLY, T7, Q9
  57. DATA ITYEL/4,8,6,10,0,0,7,11,12*0/
  58.  
  59. *dbg write(ioimp,*) 'coucou envel1'
  60. n2ptel=0
  61. n2el=0
  62. SEGACT MELEME
  63.  
  64. c on compte le nombre d elements dont les faces sont de type 1 2 3 4
  65. c 7 8 dans NBFAC
  66. SEGINI NBFAC
  67. NTPOL=0
  68. IPT1=MELEME
  69. SEGACT MELEME
  70. nbsour=lisous(/1)
  71. if (mcoup.ne.0) nbsour=nbsour-1
  72. DO 10 IOB=1,nbsour
  73. IPT1=LISOUS(IOB)
  74. SEGACT IPT1
  75. NBELEM=IPT1.NUM(/2)
  76. ILTEL=LTEL(1,IPT1.ITYPEL)
  77. IF (ILTEL.EQ.0) GOTO 12
  78. ILTAD=LTEL(2,IPT1.ITYPEL)
  79. DO 13 IF=1,ILTEL
  80. IFT=LDEL(1,ILTAD+IF-1)
  81. IF (IFT.EQ.6) THEN
  82. NTPOL=NTPOL+1
  83. ELSE
  84. NBFAC(IFT)=NBFAC(IFT)+NBELEM
  85. ENDIF
  86. 13 CONTINUE
  87. 12 CONTINUE
  88. 10 CONTINUE
  89.  
  90. c==== CREATION DES FACES ==============================================
  91. * Initialisation des IFACI,XFACI
  92. SEGINI IPOFAC
  93. DO ITYFAC=1,NTYFAC
  94. NNODE=KDFAC(1,ITYFAC)
  95. IF (NNODE.GT.0) THEN
  96. NFACI=NBFAC(ITYFAC)
  97. SEGINI IFACI
  98. IPOFAC(1,ITYFAC)=IFACI
  99. SEGINI XFACI
  100. IPOFAC(2,ITYFAC)=XFACI
  101. ENDIF
  102. ENDDO
  103. SEGINI IPPOL,IPREF
  104. c NBFAC sert maintenant de compteur
  105. DO ITYFAC=1,NTYFAC
  106. NBFAC(ITYFAC)=0
  107. ENDDO
  108. NTPOL=0
  109. DO 50 IOB=1,nbsour
  110. IPT1=LISOUS(IOB)
  111. * si objet en double on saute
  112. do 51 io2=1,iob-1
  113. if (ipt1.eq.lisous(io2)) goto 50
  114. 51 continue
  115. SEGACT IPT1
  116. IELIM=1
  117. IF (KSURF(IPT1.ITYPEL).EQ.IPT1.ITYPEL) THEN
  118. * face non eliminable (pas un volume)
  119. IELIM=0
  120. ENDIF
  121. melval=lisref(iob)
  122. if (melval.eq.0) goto 50
  123. segact melval
  124. lval=velche(/1)
  125. ival=velche(/2)
  126. NBELEM=IPT1.NUM(/2)
  127. ILTEL=LTEL(1,IPT1.ITYPEL)
  128. IF (ILTEL.EQ.0) GOTO 52
  129. ILTAD=LTEL(2,IPT1.ITYPEL)
  130. DO 60 IF=1,ILTEL
  131. ITYFAC=LDEL(1,ILTAD+IF-1)
  132. IAD=LDEL(2,ILTAD+IF-1)
  133. NNODE=KDFAC(1,ITYFAC)
  134. IF (NNODE.GT.0) THEN
  135. IFACI=IPOFAC(1,ITYFAC)
  136. XFACI=IPOFAC(2,ITYFAC)
  137. DO 66 IEL=1,NBELEM
  138. ielr=min(ival,iel)
  139. NBFAC(ITYFAC)=NBFAC(ITYFAC)+1
  140. j=NBFAC(ITYFAC)
  141. DO i=1,NNODE
  142. IFACI(i,j)=IPT1.NUM(LFAC(IAD+i-1),IEL)
  143. XFACI(i,j)=velche(min(lval,LFAC(IAD+i-1)),ielr)
  144. ENDDO
  145. IFACI(NNODE+1,j)=IPT1.ICOLOR(IEL)
  146. IFACI(NNODE+2,j)=IELIM
  147. 66 CONTINUE
  148. ENDIF
  149. * Avant ce if était après le 52 CONTINUE mais alors ITYFAC etait
  150. * potentiellement non initialise
  151. IF (ITYFAC.EQ.6) THEN
  152. C Polygone
  153. NTPOL = NTPOL+1
  154. IPPOL(NTPOL)= IPT1
  155. SEGINI,MELVA1 = MELVAL
  156. IPREF(NTPOL) = MELVA1
  157. ENDIF
  158. 60 CONTINUE
  159. 52 CONTINUE
  160. 50 CONTINUE
  161. C IF FAUT MAINTENANT RETASSER ET CLASSER LES TABLEAUX DES FACES
  162. C PROBLEME ELLES NE SONT PAS FORCEMENT DECRITES DE LA MEME FACON
  163. C SG 20160712 NTFAC sert de cle de hachage, elle est égale à la
  164. C somme des numeros de noeuds de la face
  165. NFAC=0
  166. SEGINI IDXFAC
  167. IDXFAC(1)=NFAC+1
  168. DO ITYFAC=1,NTYFAC
  169. NFAC=NFAC+NBFAC(ITYFAC)
  170. IDXFAC(ITYFAC+1)=NFAC+1
  171. * write(ioimp,*) 'ityfac=',ityfac,' nbfac=',NBFAC(ITYFAC)
  172. ENDDO
  173. SEGINI NTFAC,KFAK
  174. IFAC=0
  175. DO ITYFAC=1,NTYFAC
  176. NNODE=KDFAC(1,ITYFAC)
  177. IF (NNODE.GT.0) THEN
  178. LOPT=LOQUAF.AND.(ITYFAC.EQ.7.OR.ITYFAC.EQ.8)
  179. IFACI=IPOFAC(1,ITYFAC)
  180. DO I=1,NBFAC(ITYFAC)
  181. IFAC=IFAC+1
  182. IF (LOPT) THEN
  183. NTFAC(IFAC)=IFACI(NNODE,I)
  184. ELSE
  185. DO J=1,NNODE
  186. NTFAC(IFAC)=NTFAC(IFAC)+IFACI(J,I)
  187. ENDDO
  188. ENDIF
  189. KFAK(IFAC)=I
  190. ENDDO
  191. ENDIF
  192. ENDDO
  193. C IL N'Y A PLUS QU'A TRIER ET RETASSER KFAK SUIVANT NTFAC
  194. SEGINI NAUX
  195. DO 300 ITYFAC=1,NTYFAC
  196. IDEB=IDXFAC(ITYFAC)
  197. IFIN=IDXFAC(ITYFAC+1)-1
  198. IF (IFIN.LE.IDEB) GOTO 300
  199. NAUX(1)=IDEB
  200. NAUX(2)=IFIN
  201. IZ=2
  202. 208 IZ=IZ-1
  203. IF (IZ.LE.0) GOTO 209
  204. IPB=NAUX(IZ*2-1)
  205. IPH=NAUX(IZ*2)
  206. IF(IPB.GE.IPH) GOTO 208
  207. JPB=IPB-1
  208. JPH=IPH+1
  209. C CALCUL DU PIVOT
  210. NPV=0
  211. * DO 207 J=IPB,IPH
  212. * NPV=NPV+NTFAC(J)
  213. *207 CONTINUE
  214. * NPV=NPV/(IPH-IPB+1)
  215. NPV=(NTFAC(IPB)+NTFAC(IPH))/2
  216. 242 JPB=JPB+1
  217. IF (JPH.EQ.JPB) GOTO 245
  218. IF (NTFAC(JPB).LE.NPV) GOTO 243
  219. GOTO 242
  220. 243 JPH=JPH-1
  221. IF (JPH.EQ.JPB) GOTO 245
  222. IF (NTFAC(JPH).GE.NPV) GOTO 244
  223. GOTO 243
  224. 244 IAUX=KFAK(JPB)
  225. KFAK(JPB)=KFAK(JPH)
  226. KFAK(JPH)=IAUX
  227. NTAUX=NTFAC(JPB)
  228. NTFAC(JPB)=NTFAC(JPH)
  229. NTFAC(JPH)=NTAUX
  230. GOTO 242
  231. 245 IF (JPB.GE.IPB) GOTO 247
  232. JPB=JPB+1
  233. JPH=JPH+2
  234. GOTO 248
  235. 247 IF (JPH.LE.IPH) GOTO 249
  236. JPB=JPB-2
  237. JPH=JPH-1
  238. GOTO 248
  239. 249 IF (NTFAC(JPB).LE.NPV) GOTO 250
  240. IF (JPH.EQ.IPH) GOTO 251
  241. 252 JPH=JPH+1
  242. GOTO 248
  243. 250 IF (JPB.EQ.IPB) GOTO 252
  244. 251 JPB=JPB-1
  245. 248 IF (JPB.EQ.IPB) GOTO 253
  246. NAUX(2*IZ)=JPB
  247. IZ=IZ+1
  248. 253 IF (JPH.EQ.IPH) GOTO 208
  249. NAUX(2*IZ)=IPH
  250. NAUX(2*IZ-1)=JPH
  251. IZ=IZ+1
  252. GOTO 208
  253. 209 CONTINUE
  254. 300 CONTINUE
  255. C LES FACES SONT CLASSEES DANS KFAK IL FAUT ELIMINER LES FACES EN DOUBL
  256. C ELLES SONT PAR TYPE LES UNES DERRIERES LES AUTRES LES PLUS HAUTES
  257. C DEVANT
  258. IF (IIMPI.NE.0) WRITE (IOIMP,9111) (KFAK(I),NTFAC(I),I=1,NFAC)
  259. 9111 FORMAT(5(2X,2I6))
  260. DO 400 ITYFAC=1,NTYFAC
  261. IDEB=IDXFAC(ITYFAC)
  262. IFIN=IDXFAC(ITYFAC+1)-1
  263. IF (IFIN.LE.IDEB) GOTO 400
  264. NNODE=KDFAC(1,ITYFAC)
  265. * A cette etape on doit avoir nnode.gt.0
  266. IF (NNODE.LE.0) THEN
  267. CALL ERREUR(5)
  268. RETURN
  269. ENDIF
  270. LOPT=LOQUAF.AND.(ITYFAC.EQ.7.OR.ITYFAC.EQ.8)
  271. IFACI=IPOFAC(1,ITYFAC)
  272. *
  273. IFINM=IFIN-1
  274. DO 450 I1=IDEB,IFINM
  275. NTI1=NTFAC(I1)
  276. IF (NTI1.EQ.0) GOTO 450
  277. IDEB1=I1+1
  278. DO 460 I2=IDEB1,IFIN
  279. NTI2=NTFAC(I2)
  280. IF (NTI2.EQ.0) GOTO 460
  281. IF (NTI2.NE.NTI1) GOTO 450
  282. IR1=KFAK(I1)
  283. IR2=KFAK(I2)
  284. IF (IFACI(NNODE+2,IR1).EQ.0) GOTO 460
  285. IF (IFACI(NNODE+2,IR2).EQ.0) GOTO 460
  286. IF (.NOT.LOPT) THEN
  287. DO 471 J1=1,NNODE
  288. INU=IFACI(J1,IR1)
  289. DO 472 J2=1,NNODE
  290. IF (INU.EQ.IFACI(J2,IR2)) GOTO 471
  291. 472 CONTINUE
  292. GOTO 460
  293. 471 CONTINUE
  294. ENDIF
  295. C DEUX FACES EGALES ON LES SUPPRIMENT
  296. NTFAC(I1)=0
  297. NTFAC(I2)=0
  298. GOTO 450
  299. 460 CONTINUE
  300. 450 CONTINUE
  301. 400 CONTINUE
  302. *
  303. IF (IIMPI.NE.0) WRITE (IOIMP,9111) (KFAK(I),NTFAC(I),I=1,NFAC)
  304.  
  305. SEGINI IPTFAC,MLVFAC
  306. NBSOUS=0
  307. NBREF=0
  308. NBSOU2=0
  309. DO 600 ITYFAC=1,NTYFAC
  310. IDEB=IDXFAC(ITYFAC)
  311. IFIN=IDXFAC(ITYFAC+1)-1
  312. * write(ioimp,*) 'ityfac=',ityfac,' ideb=',ideb,' ifin=',ifin
  313. IF (IFIN.LT.IDEB) GOTO 600
  314. NNODE=KDFAC(1,ITYFAC)
  315. * A cette etape on doit avoir nnode.gt.0
  316. IF (NNODE.LE.0) THEN
  317. CALL ERREUR(5)
  318. RETURN
  319. ENDIF
  320. IFACI=IPOFAC(1,ITYFAC)
  321. XFACI=IPOFAC(2,ITYFAC)
  322. NBELEM=0
  323. DO 611 I=IDEB,IFIN
  324. IF (NTFAC(I).NE.0) NBELEM=NBELEM+1
  325. 611 CONTINUE
  326. * write(ioimp,*) 'nbelem=',nbelem,' nnode=',nnode
  327. IF (NBELEM.EQ.0) GOTO 600
  328. NBSOU2=NBSOU2+1
  329. NBNN=NNODE
  330. SEGINI IPT1
  331. IPT1.ITYPEL=ITYEL(ITYFAC)
  332. n1ptel=nnode
  333. n1el=nbelem
  334. segini melva1
  335. JAUX=0
  336. DO 612 J=IDEB,IFIN
  337. IF (NTFAC(J).EQ.0) GOTO 612
  338. JAUX=JAUX+1
  339. IPT1.ICOLOR(JAUX)=IFACI(NNODE+1,KFAK(J))
  340. DO 613 I=1,NBNN
  341. IPT1.NUM(I,JAUX)=IFACI(I,KFAK(J))
  342. melva1.velche(I,JAUX)=XFACI(I,KFAK(J))
  343. 613 CONTINUE
  344. 612 CONTINUE
  345. IPTFAC(ITYFAC)=IPT1
  346. * write(ioimp,*) 'ipt1=',ipt1
  347. MLVFAC(ITYFAC)=melva1
  348. 600 CONTINUE
  349. * on rajoute les points et les segments qui pouvaient etre dans le
  350. * maillage initial
  351. ipt5=0
  352. segact meleme
  353. ipt6=meleme
  354. do 710 io=1,max(1,nbsour)
  355. if (nbsour.ne.0) ipt6=lisous(io)
  356. segact ipt6
  357. if (ipt6.itypel.le.3) then
  358. nbsou2=nbsou2+1
  359. ipt5=ipt6
  360. endif
  361. 710 continue
  362. * write(ioimp,*) 'nbsou2=',nbsou2
  363. NBSOUS=NBSOU2+NTPOL
  364. if (mcoup.ne.0) nbsous=nbsous+1
  365. IF (NBSOUS.EQ.0) CALL ERREUR(26)
  366. IF (IERR.NE.0) RETURN
  367. NBREF=nbsous
  368. NBNN=0
  369. NBELEM=0
  370. SEGINI IPT5
  371. I=0
  372. DO ITYFAC=1,NTYFAC
  373. IPT1=IPTFAC(ITYFAC)
  374. melva1=MLVFAC(ITYFAC)
  375. IF (IPT1.NE.0) THEN
  376. if (melva1.eq.0) then
  377. call erreur(5)
  378. return
  379. endif
  380. I=I+1
  381. IPT5.LISOUS(I)=IPT1
  382. IPT5.LISref(I)=melva1
  383. ENDIF
  384. ENDDO
  385. segact meleme
  386. ipt1=meleme
  387. do 711 io=1,max(1,nbsour)
  388. if (nbsour.ne.0) ipt1=lisous(io)
  389. segact ipt1
  390. if (ipt1.itypel.le.3) then
  391. I=I+1
  392. IPT5.LISOUS(I)=IPT1
  393. IPT5.LISref(I)=lisref(io)
  394. endif
  395. 711 continue
  396. DO 720, IO = 1, NTPOL
  397. I= I+1
  398. IPT5.LISOUS(I) = IPPOL(IO)
  399. IPT5.LISREF(I) = IPREF(IO)
  400. 720 CONTINUE
  401. if (mcoup.ne.0) then
  402. I= I+1
  403. IPT5.LISOUS(I) = lisous(nbsour+1)
  404. IPT5.LISREF(I) = lisref(nbsour+1)
  405. endif
  406. melres=ipt5
  407.  
  408. SEGSUP IPTFAC,MLVFAC,NAUX,NTFAC,KFAK,IDXFAC,IPPOL,IPREF
  409. DO ITYFAC=1,NTYFAC
  410. IFACI=IPOFAC(1,ITYFAC)
  411. IF (IFACI.NE.0) THEN
  412. SEGSUP IFACI
  413. ENDIF
  414. XFACI=IPOFAC(2,ITYFAC)
  415. IF (XFACI.NE.0) THEN
  416. SEGSUP XFACI
  417. ENDIF
  418. ENDDO
  419. SEGSUP IPOFAC,NBFAC
  420. END
  421.  
  422.  
  423.  

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