Télécharger envel1.eso

Retour à la liste

Numérotation des lignes :

  1. C ENVEL1 SOURCE BP208322 16/11/18 21:16:43 9177
  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. IF (LISOUS(/1).NE.0) SEGDES IPT1
  161. 50 CONTINUE
  162. SEGDES MELEME
  163. C IF FAUT MAINTENANT RETASSER ET CLASSER LES TABLEAUX DES FACES
  164. C PROBLEME ELLES NE SONT PAS FORCEMENT DECRITES DE LA MEME FACON
  165. C SG 20160712 NTFAC sert de cle de hachage, elle est égale à la
  166. C somme des numeros de noeuds de la face
  167. NFAC=0
  168. SEGINI IDXFAC
  169. IDXFAC(1)=NFAC+1
  170. DO ITYFAC=1,NTYFAC
  171. NFAC=NFAC+NBFAC(ITYFAC)
  172. IDXFAC(ITYFAC+1)=NFAC+1
  173. * write(ioimp,*) 'ityfac=',ityfac,' nbfac=',NBFAC(ITYFAC)
  174. ENDDO
  175. SEGINI NTFAC,KFAK
  176. IFAC=0
  177. DO ITYFAC=1,NTYFAC
  178. NNODE=KDFAC(1,ITYFAC)
  179. IF (NNODE.GT.0) THEN
  180. LOPT=LOQUAF.AND.(ITYFAC.EQ.7.OR.ITYFAC.EQ.8)
  181. IFACI=IPOFAC(1,ITYFAC)
  182. DO I=1,NBFAC(ITYFAC)
  183. IFAC=IFAC+1
  184. IF (LOPT) THEN
  185. NTFAC(IFAC)=IFACI(NNODE,I)
  186. ELSE
  187. DO J=1,NNODE
  188. NTFAC(IFAC)=NTFAC(IFAC)+IFACI(J,I)
  189. ENDDO
  190. ENDIF
  191. KFAK(IFAC)=I
  192. ENDDO
  193. ENDIF
  194. ENDDO
  195. C IL N'Y A PLUS QU'A TRIER ET RETASSER KFAK SUIVANT NTFAC
  196. SEGINI NAUX
  197. DO 300 ITYFAC=1,NTYFAC
  198. IDEB=IDXFAC(ITYFAC)
  199. IFIN=IDXFAC(ITYFAC+1)-1
  200. IF (IFIN.LE.IDEB) GOTO 300
  201. NAUX(1)=IDEB
  202. NAUX(2)=IFIN
  203. IZ=2
  204. 208 IZ=IZ-1
  205. IF (IZ.LE.0) GOTO 209
  206. IPB=NAUX(IZ*2-1)
  207. IPH=NAUX(IZ*2)
  208. IF(IPB.GE.IPH) GOTO 208
  209. JPB=IPB-1
  210. JPH=IPH+1
  211. C CALCUL DU PIVOT
  212. NPV=0
  213. * DO 207 J=IPB,IPH
  214. * NPV=NPV+NTFAC(J)
  215. *207 CONTINUE
  216. * NPV=NPV/(IPH-IPB+1)
  217. NPV=(NTFAC(IPB)+NTFAC(IPH))/2
  218. 242 JPB=JPB+1
  219. IF (JPH.EQ.JPB) GOTO 245
  220. IF (NTFAC(JPB).LE.NPV) GOTO 243
  221. GOTO 242
  222. 243 JPH=JPH-1
  223. IF (JPH.EQ.JPB) GOTO 245
  224. IF (NTFAC(JPH).GE.NPV) GOTO 244
  225. GOTO 243
  226. 244 IAUX=KFAK(JPB)
  227. KFAK(JPB)=KFAK(JPH)
  228. KFAK(JPH)=IAUX
  229. NTAUX=NTFAC(JPB)
  230. NTFAC(JPB)=NTFAC(JPH)
  231. NTFAC(JPH)=NTAUX
  232. GOTO 242
  233. 245 IF (JPB.GE.IPB) GOTO 247
  234. JPB=JPB+1
  235. JPH=JPH+2
  236. GOTO 248
  237. 247 IF (JPH.LE.IPH) GOTO 249
  238. JPB=JPB-2
  239. JPH=JPH-1
  240. GOTO 248
  241. 249 IF (NTFAC(JPB).LE.NPV) GOTO 250
  242. IF (JPH.EQ.IPH) GOTO 251
  243. 252 JPH=JPH+1
  244. GOTO 248
  245. 250 IF (JPB.EQ.IPB) GOTO 252
  246. 251 JPB=JPB-1
  247. 248 IF (JPB.EQ.IPB) GOTO 253
  248. NAUX(2*IZ)=JPB
  249. IZ=IZ+1
  250. 253 IF (JPH.EQ.IPH) GOTO 208
  251. NAUX(2*IZ)=IPH
  252. NAUX(2*IZ-1)=JPH
  253. IZ=IZ+1
  254. GOTO 208
  255. 209 CONTINUE
  256. 300 CONTINUE
  257. C LES FACES SONT CLASSEES DANS KFAK IL FAUT ELIMINER LES FACES EN DOUBL
  258. C ELLES SONT PAR TYPE LES UNES DERRIERES LES AUTRES LES PLUS HAUTES
  259. C DEVANT
  260. IF (IIMPI.NE.0) WRITE (IOIMP,9111) (KFAK(I),NTFAC(I),I=1,NFAC)
  261. 9111 FORMAT(5(2X,2I6))
  262. DO 400 ITYFAC=1,NTYFAC
  263. IDEB=IDXFAC(ITYFAC)
  264. IFIN=IDXFAC(ITYFAC+1)-1
  265. IF (IFIN.LE.IDEB) GOTO 400
  266. NNODE=KDFAC(1,ITYFAC)
  267. * A cette etape on doit avoir nnode.gt.0
  268. IF (NNODE.LE.0) THEN
  269. CALL ERREUR(5)
  270. RETURN
  271. ENDIF
  272. LOPT=LOQUAF.AND.(ITYFAC.EQ.7.OR.ITYFAC.EQ.8)
  273. IFACI=IPOFAC(1,ITYFAC)
  274. *
  275. IFINM=IFIN-1
  276. DO 450 I1=IDEB,IFINM
  277. NTI1=NTFAC(I1)
  278. IF (NTI1.EQ.0) GOTO 450
  279. IDEB1=I1+1
  280. DO 460 I2=IDEB1,IFIN
  281. NTI2=NTFAC(I2)
  282. IF (NTI2.EQ.0) GOTO 460
  283. IF (NTI2.NE.NTI1) GOTO 450
  284. IR1=KFAK(I1)
  285. IR2=KFAK(I2)
  286. IF (IFACI(NNODE+2,IR1).EQ.0) GOTO 460
  287. IF (IFACI(NNODE+2,IR2).EQ.0) GOTO 460
  288. IF (.NOT.LOPT) THEN
  289. DO 471 J1=1,NNODE
  290. INU=IFACI(J1,IR1)
  291. DO 472 J2=1,NNODE
  292. IF (INU.EQ.IFACI(J2,IR2)) GOTO 471
  293. 472 CONTINUE
  294. GOTO 460
  295. 471 CONTINUE
  296. ENDIF
  297. C DEUX FACES EGALES ON LES SUPPRIMENT
  298. NTFAC(I1)=0
  299. NTFAC(I2)=0
  300. GOTO 450
  301. 460 CONTINUE
  302. 450 CONTINUE
  303. 400 CONTINUE
  304. *
  305. IF (IIMPI.NE.0) WRITE (IOIMP,9111) (KFAK(I),NTFAC(I),I=1,NFAC)
  306.  
  307. SEGINI IPTFAC,MLVFAC
  308. NBSOUS=0
  309. NBREF=0
  310. NBSOU2=0
  311. DO 600 ITYFAC=1,NTYFAC
  312. IDEB=IDXFAC(ITYFAC)
  313. IFIN=IDXFAC(ITYFAC+1)-1
  314. * write(ioimp,*) 'ityfac=',ityfac,' ideb=',ideb,' ifin=',ifin
  315. IF (IFIN.LT.IDEB) GOTO 600
  316. NNODE=KDFAC(1,ITYFAC)
  317. * A cette etape on doit avoir nnode.gt.0
  318. IF (NNODE.LE.0) THEN
  319. CALL ERREUR(5)
  320. RETURN
  321. ENDIF
  322. IFACI=IPOFAC(1,ITYFAC)
  323. XFACI=IPOFAC(2,ITYFAC)
  324. NBELEM=0
  325. DO 611 I=IDEB,IFIN
  326. IF (NTFAC(I).NE.0) NBELEM=NBELEM+1
  327. 611 CONTINUE
  328. * write(ioimp,*) 'nbelem=',nbelem,' nnode=',nnode
  329. IF (NBELEM.EQ.0) GOTO 600
  330. NBSOU2=NBSOU2+1
  331. NBNN=NNODE
  332. SEGINI IPT1
  333. IPT1.ITYPEL=ITYEL(ITYFAC)
  334. n1ptel=nnode
  335. n1el=nbelem
  336. segini melva1
  337. JAUX=0
  338. DO 612 J=IDEB,IFIN
  339. IF (NTFAC(J).EQ.0) GOTO 612
  340. JAUX=JAUX+1
  341. IPT1.ICOLOR(JAUX)=IFACI(NNODE+1,KFAK(J))
  342. DO 613 I=1,NBNN
  343. IPT1.NUM(I,JAUX)=IFACI(I,KFAK(J))
  344. melva1.velche(I,JAUX)=XFACI(I,KFAK(J))
  345. 613 CONTINUE
  346. 612 CONTINUE
  347. SEGDES IPT1
  348. IPTFAC(ITYFAC)=IPT1
  349. * write(ioimp,*) 'ipt1=',ipt1
  350. MLVFAC(ITYFAC)=melva1
  351. 600 CONTINUE
  352. * on rajoute les points et les segments qui pouvaient etre dans le
  353. * maillage initial
  354. ipt5=0
  355. segact meleme
  356. ipt6=meleme
  357. do 710 io=1,max(1,nbsour)
  358. if (nbsour.ne.0) ipt6=lisous(io)
  359. segact ipt6
  360. if (ipt6.itypel.le.3) then
  361. nbsou2=nbsou2+1
  362. ipt5=ipt6
  363. endif
  364. segdes ipt6
  365. 710 continue
  366. segdes meleme
  367. * write(ioimp,*) 'nbsou2=',nbsou2
  368. NBSOUS=NBSOU2+NTPOL
  369. if (mcoup.ne.0) nbsous=nbsous+1
  370. IF (NBSOUS.EQ.0) CALL ERREUR(26)
  371. IF (IERR.NE.0) RETURN
  372. NBREF=nbsous
  373. NBNN=0
  374. NBELEM=0
  375. SEGINI IPT5
  376. I=0
  377. DO ITYFAC=1,NTYFAC
  378. IPT1=IPTFAC(ITYFAC)
  379. melva1=MLVFAC(ITYFAC)
  380. IF (IPT1.NE.0) THEN
  381. if (melva1.eq.0) then
  382. call erreur(5)
  383. return
  384. endif
  385. I=I+1
  386. IPT5.LISOUS(I)=IPT1
  387. IPT5.LISref(I)=melva1
  388. ENDIF
  389. ENDDO
  390. segact meleme
  391. ipt1=meleme
  392. do 711 io=1,max(1,nbsour)
  393. if (nbsour.ne.0) ipt1=lisous(io)
  394. segact ipt1
  395. if (ipt1.itypel.le.3) then
  396. I=I+1
  397. IPT5.LISOUS(I)=IPT1
  398. IPT5.LISref(I)=lisref(io)
  399. endif
  400. segdes ipt1
  401. 711 continue
  402. DO 720, IO = 1, NTPOL
  403. I= I+1
  404. IPT5.LISOUS(I) = IPPOL(IO)
  405. IPT5.LISREF(I) = IPREF(IO)
  406. 720 CONTINUE
  407. if (mcoup.ne.0) then
  408. I= I+1
  409. IPT5.LISOUS(I) = lisous(nbsour+1)
  410. IPT5.LISREF(I) = lisref(nbsour+1)
  411. endif
  412. segdes meleme
  413. melres=ipt5
  414.  
  415. SEGSUP IPTFAC,MLVFAC
  416. SEGSUP NAUX
  417. SEGSUP NTFAC,KFAK
  418. SEGSUP IDXFAC
  419. SEGSUP IPPOL,IPREF
  420. DO ITYFAC=1,NTYFAC
  421. IFACI=IPOFAC(1,ITYFAC)
  422. IF (IFACI.NE.0) THEN
  423. SEGSUP IFACI
  424. ENDIF
  425. XFACI=IPOFAC(2,ITYFAC)
  426. IF (XFACI.NE.0) THEN
  427. SEGSUP XFACI
  428. ENDIF
  429. ENDDO
  430. SEGSUP IPOFAC
  431. SEGSUP NBFAC
  432. RETURN
  433. END
  434.  
  435.  
  436.  
  437.  
  438.  
  439.  
  440.  
  441.  
  442.  
  443.  
  444.  
  445.  
  446.  
  447.  
  448.  
  449.  
  450.  
  451.  
  452.  
  453.  

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