Télécharger envvo2.eso

Retour à la liste

Numérotation des lignes :

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

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