Télécharger genera.eso

Retour à la liste

Numérotation des lignes :

genera
  1. C GENERA SOURCE SP204843 25/03/14 21:15:05 12201
  2. C OPTION GENERATRICE
  3. C
  4. SUBROUTINE GENERA
  5. IMPLICIT INTEGER(I-N)
  6. IMPLICIT REAL*8 (A-H,O-Z)
  7. DIMENSION XCO(4)
  8.  
  9. -INC PPARAM
  10. -INC CCOPTIO
  11. -INC CCGEOME
  12. -INC SMCOORD
  13. -INC SMELEME
  14. -INC CCTOURN
  15. logical ltelq
  16. SEGMENT ICPR(2,NBELEC)
  17. SEGMENT ICPP(nbpts)
  18.  
  19. IF (KSURF(ILCOUR).EQ.0) CALL ERREUR(16)
  20. IF (IERR.NE.0) RETURN
  21. CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  22. IF (IERR.NE.0) RETURN
  23. CALL EXTRLI(IPT1,3,IRET,-1)
  24. IF (IERR.NE.0) RETURN
  25.  
  26. IFUSE=0
  27. IF (IPT1.NE.IRET) IFUSE=IPT1
  28. IPT1=IRET
  29. CALL LIROBJ('MAILLAGE',IPT8,1,IRETOU)
  30. IF (IERR.NE.0) RETURN
  31.  
  32. SEGACT IPT8
  33. IF (IPT8.ITYPEL.NE.KDEGRE(ILCOUR)) CALL ERREUR(16)
  34. IF (IERR.NE.0) RETURN
  35.  
  36. NCOUCH=IPT8.NUM(/2)
  37. SEGACT IPT1
  38. SEGACT MCOORD*mod
  39. NBNN =IPT1.NUM(/1)
  40. NBELEM=IPT1.NUM(/2)
  41. IBOUCL=0
  42. IF (IPT1.NUM(1,1).EQ.IPT1.NUM(NBNN,NBELEM)) IBOUCL=1
  43.  
  44. 20 CONTINUE
  45. NX=NCOUCH-1
  46. IF (IIMPI.EQ.1) WRITE (IOIMP,1000) NCOUCH
  47. 1000 FORMAT(/,' COUCHES ',I6)
  48. NBNN =4
  49. NBELEM=IPT1.NUM(/2)*NCOUCH
  50. NBSOUS=0
  51. NBREF =4
  52. SEGINI,MELEME
  53. ITYPEL=8
  54. INCR =IPT1.ITYPEL-1
  55. IL =1
  56. NBELEC=IPT1.NUM(/2)
  57. SEGINI,ICPR
  58.  
  59. C ON FAIT D'ABORD L' EXTREMITEE
  60. SEGINI,ICPP
  61. DO 52 I=1,ICPP(/1)
  62. ICPP(I)=0
  63. 52 CONTINUE
  64.  
  65. ICLE =1
  66. IPBAS =IPT8.NUM(1,1)
  67. IPHAU =IPT8.NUM(IPT8.NUM(/1),NCOUCH)
  68. IREFB =(IDIM+1)*(IPBAS-1)
  69. IREFH =(IDIM+1)*(IPHAU-1)
  70.  
  71. DO 200 I=1,IDIM+1
  72. XCO(I)=XCOOR(IREFH+I)-XCOOR(IREFB+I)
  73. 200 CONTINUE
  74.  
  75. CALL ADDITE(XCO,IPT1,IPT3,ICPP,0)
  76. IF (IERR.NE.0) RETURN
  77. SEGSUP ICPP
  78. SEGACT MCOORD*mod
  79. SEGACT IPT3
  80. CALL INVERS(IPT3,IPT4)
  81. SEGDES IPT4
  82. LISREF(3)=IPT4
  83. C ON REMPLIT LE TABLEAU ICPR DES PTS EFFECTIFS
  84. IDEB=nbpts+1
  85. DO 70 I=1,2
  86. DO 700 J=1,NBELEC
  87. ICPR(I,J)=0
  88. 700 CONTINUE
  89. 70 CONTINUE
  90. LCPR=0
  91. DO 71 J=1,NBELEC
  92. DO 710 I=1,2
  93. I1=IPT1.NUM((I-1)*INCR+1,J)
  94. LCPR=LCPR+1
  95. DO 72 JJ=1,J
  96. DO 720 II=1,2
  97. IF (IPT1.NUM((II-1)*INCR+1,JJ).NE.I1) GOTO 720
  98. IF (II.NE.I) GOTO 73
  99. IF (JJ.EQ.J) GOTO 710
  100. 73 ICPR(I,J)=II+(JJ-1)*2
  101. LCPR=LCPR-1
  102. IF (J.EQ.NBELEC.AND.I.EQ.2) GOTO 75
  103. GOTO 710
  104. 75 IF (IBOUCL.EQ.1) GOTO 710
  105. ICPR(I,J)=0
  106. ICPR(II,JJ)=I+(J-1)*2
  107. GOTO 710
  108. 720 CONTINUE
  109. 72 CONTINUE
  110. 710 CONTINUE
  111. 71 CONTINUE
  112. * IL SEMBLERAIT QUE L'ON AIT NCOUCH A FAIRE AVEC LCPR POINTS EFFECTIFS
  113. C ON NE S'OCCUPE QUE DE FABRIQUER DES RECTANGLES A 4 NOEUDS POUR
  114. C LE MOMENT D'ABORD LES POINTS DU BAS QUI NE SONT PAS A FABRIQUER
  115. DO 40 I=1,IPT1.NUM(/2)
  116. NUM(1,I)=IPT1.NUM(1,I)
  117. NUM(2,I)=IPT1.NUM(1+INCR,I)
  118. 40 CONTINUE
  119. ILASI=IDEB-1
  120. ILASJ=ILASI+(INCR*NX)+INCR-1
  121. IF (IBOUCL.EQ.1) ILASJ=ILASI
  122. ILAS=ILASJ+INCR*NX+INCR
  123. DO 42 ICOUCH=1,NCOUCH
  124. IF (NCOUCH.EQ.ICOUCH) GOTO 41
  125. ILASI=ILASI+INCR
  126. ILASJ=ILASJ+INCR
  127. INI=(ICOUCH-1)*IPT1.NUM(/2)
  128. NUM(1,1+INI+NBELEC)=ILASI
  129. NUM(4,1+INI)=ILASI
  130. NUM(2,INI+2*NBELEC)=ILASJ
  131. NUM(3,INI+NBELEC)=ILASJ
  132. DO 420 J=1,IPT1.NUM(/2)
  133. DO 421 I=1,2
  134. ILL=ILAS
  135. IF (I.EQ.1.AND.J.EQ.1) GOTO 421
  136. IF (I.EQ.2.AND.J.EQ.NBELEC) GOTO 421
  137. IF (ICPR(I,J).NE.0) ILL=NUM(MOD(ICPR(I,J)-1,2)+1,
  138. # (ICPR(I,J)-1)/2+1+INI+NBELEC)
  139. NUM(I,J+INI+NBELEC)=ILL
  140. NUM(5-I,J+INI)=ILL
  141. IF (ICPR(I,J).NE.0) GOTO 421
  142. ILAS=ILL+1
  143. 421 CONTINUE
  144. 420 CONTINUE
  145. 42 CONTINUE
  146. 41 CONTINUE
  147. INI=(NCOUCH-1)*IPT1.NUM(/2)
  148. DO 43 I=1,NBELEC
  149. NUM(4,INI+I)=IPT3.NUM(1,I)
  150. NUM(3,INI+I)=IPT3.NUM(1+INCR,I)
  151. 43 CONTINUE
  152. DO 44 I=1,NCOUCH
  153. DO 440 J=1,IPT1.NUM(/2)
  154. II=(I-1)*IPT1.NUM(/2)+J
  155. ICOLOR(II)=IPT1.ICOLOR(J)
  156. 440 CONTINUE
  157. 44 CONTINUE
  158. LISREF(1)=IPT1
  159. C CREATION DES BORDS LATERAUX PAR LIGNE PETIT SOUCI
  160. C CECI EST A REVOIR (NOUVEAU S-P POUR CE CAS QUI RESPECTE LA
  161. C NUMEROTATION
  162. ILS=IPT1.ITYPEL
  163. IDS=IPT1.ICOLOR(1)
  164. LP1=IPT1.NUM(1,1)
  165. LP2=IPT3.NUM(1,1)
  166. CALL GENERL(LP1,LP2,IPT8,IPT2,IDS)
  167. IF (IERR.NE.0) RETURN
  168. CALL INVERS(IPT2,IPT4)
  169. LISREF(4)=IPT4
  170. SEGDES IPT4,IPT2
  171. IF (IBOUCL.EQ.0) GOTO 46
  172. LISREF(2)=IPT2
  173. GOTO 45
  174. 46 CONTINUE
  175. IDS=IPT1.ICOLOR(IPT1.ICOLOR(/1))
  176. LP2=IPT3.NUM(IPT3.NUM(/1),IPT3.NUM(/2))
  177. LP1=IPT1.NUM(IPT1.NUM(/1),IPT1.NUM(/2))
  178. CALL GENERL(LP1,LP2,IPT8,IPT2,IDS)
  179. IF (IERR.NE.0) RETURN
  180. SEGDES IPT2
  181. LISREF(2)=IPT2
  182. 45 CONTINUE
  183. SEGSUP IPT3
  184. C CREATION DES POINTS (PAS LES POINTS MILIEUX QUI SERONT FABRIQUES
  185. C EVENTUELLEMENT LORS DE LA CONVERSION DES ELEMENTS)
  186. IADR=nbpts
  187. IF (NCOUCH.EQ.1) GOTO 60
  188. NBPTS=IADR+IPT1.NUM(/2)*(NCOUCH-1)*2
  189. SEGADJ MCOORD
  190. DO 61 I=2,NCOUCH
  191. IF (IPT1.NUM(/2).EQ.1) GOTO 60
  192. IREFI=(IDIM+1)*(IPT8.NUM(1,I)-1)
  193. XVI=XCOOR(IREFI+1)-XCOOR(IREFB+1)
  194. YVI=XCOOR(IREFI+2)-XCOOR(IREFB+2)
  195. ZVI=XCOOR(IREFI+3)-XCOOR(IREFB+3)
  196. DO 62 J=1,IPT1.NUM(/2)
  197. DO 620 K=1,2
  198. IF (K.EQ.1.AND.J.EQ.1) GOTO 620
  199. IF (K.EQ.2.AND.J.EQ.NBELEC) GOTO 620
  200. IF (ICPR(K,J).NE.0) GOTO 620
  201. IREF=(IDIM+1)*IPT1.NUM((K-1)*INCR+1,J)-IDIM
  202. XCOOR(IADR*(IDIM+1)+1)=XCOOR(IREF)+XVI
  203. XCOOR(IADR*(IDIM+1)+2)=XCOOR(IREF+1)+YVI
  204. IF (IDIM.NE.2) XCOOR(IADR*(IDIM+1)+3)=XCOOR(IREF+2)+ZVI
  205. XCOOR(IADR*(IDIM+1)+(IDIM+1))=XCOOR(IREF+IDIM)
  206. IADR=IADR+1
  207. 620 CONTINUE
  208. 62 CONTINUE
  209. 61 CONTINUE
  210. 60 CONTINUE
  211. NBPTS=IADR
  212. SEGADJ MCOORD
  213. IF (KSURF(ILCOUR).EQ.8) GOTO 101
  214. IF (KSURF(ILCOUR).NE.4) GOTO 102
  215. NBNN=3
  216. NBELEM=2*NUM(/2)
  217. NBREF=4
  218. NBSOUS=0
  219. SEGINI IPT1
  220. IPT1.ITYPEL=4
  221. IPT1.LISREF(1)=LISREF(1)
  222. IPT1.LISREF(2)=LISREF(2)
  223. IPT1.LISREF(3)=LISREF(3)
  224. IPT1.LISREF(4)=LISREF(4)
  225. DO 103 I=1,NUM(/2),2
  226. J=2*I-1
  227. IPT1.NUM(1,J)=NUM(1,I)
  228. IPT1.NUM(2,J)=NUM(2,I)
  229. IPT1.NUM(3,J)=NUM(3,I)
  230. IPT1.ICOLOR(J)=ICOLOR(I)
  231. J=J+1
  232. IPT1.NUM(1,J)=NUM(1,I)
  233. IPT1.NUM(2,J)=NUM(3,I)
  234. IPT1.NUM(3,J)=NUM(4,I)
  235. IPT1.ICOLOR(J)=ICOLOR(I)
  236. J=J+1
  237. IF (J.GT.IPT1.NUM(/2)) GOTO 103
  238. IPT1.NUM(1,J)=NUM(1,I+1)
  239. IPT1.NUM(2,J)=NUM(2,I+1)
  240. IPT1.NUM(3,J)=NUM(4,I+1)
  241. IPT1.ICOLOR(J)=ICOLOR(I+1)
  242. J=J+1
  243. IPT1.NUM(1,J)=NUM(2,I+1)
  244. IPT1.NUM(2,J)=NUM(3,I+1)
  245. IPT1.NUM(3,J)=NUM(4,I+1)
  246. IPT1.ICOLOR(J)=ICOLOR(I+1)
  247. 103 CONTINUE
  248. SEGSUP MELEME
  249. MELEME=IPT1
  250. GOTO 101
  251. 102 CONTINUE
  252. IF (KSURF(ILCOUR).NE.10.AND.KSURF(ILCOUR).NE.6) GOTO 104
  253. C ON FAIT DES QUA8 OU DES TRI6
  254. NBNN=8
  255. NBELEM=NUM(/2)
  256. NBREF=4
  257. NBSOUS=0
  258. SEGINI IPT5
  259. IPT5.ITYPEL=10
  260. IPT1=LISREF(1)
  261. IPT2=LISREF(2)
  262. IPT3=LISREF(3)
  263. IPT4=LISREF(4)
  264. IPT5.LISREF(1)=IPT1
  265. IPT5.LISREF(2)=IPT2
  266. IPT5.LISREF(3)=IPT3
  267. IPT5.LISREF(4)=IPT4
  268. SEGACT IPT1,IPT2,IPT3,IPT4
  269. DO 105 J=1,NUM(/1)
  270. JJ=2*J-1
  271. DO 1050 I=1,NBELEM
  272. IPT5.NUM(JJ,I)=NUM(J,I)
  273. 1050 CONTINUE
  274. 105 CONTINUE
  275. DO 135 I=1,NBELEM
  276. IPT5.ICOLOR(I)=ICOLOR(I)
  277. 135 CONTINUE
  278. NLIG=IPT1.NUM(/2)
  279. DO 106 I=1,NLIG
  280. IPT5.NUM(2,I)=IPT1.NUM(2,I)
  281. IPT5.NUM(6,NBELEM+1-I)=IPT3.NUM(2,I)
  282. 106 CONTINUE
  283. NBPTA=nbpts
  284. NBPTS=NBPTA+NCOUCH*(NLIG+NLIG*2)
  285. SEGADJ MCOORD
  286. DO 107 I=1,NCOUCH
  287. IPT5.NUM(8,NLIG*(I-1)+1)=IPT4.NUM(2,NCOUCH+1-I)
  288. IPT5.NUM(4,NLIG*I)=IPT2.NUM(2,I)
  289. C ON FAIT D'ABORD LES NOEUDS 2 DU HAUT (6 DU BAS)
  290. C CREATION DES NOEUDS
  291. IF (I.EQ.NCOUCH) GOTO 108
  292. IREFI=(IDIM+1)*(IPT8.NUM(IPT8.NUM(/1),I)-1)
  293. XVI=XCOOR(IREFI+1)-XCOOR(IREFB+1)
  294. YVI=XCOOR(IREFI+2)-XCOOR(IREFB+2)
  295. ZVI=XCOOR(IREFI+3)-XCOOR(IREFB+3)
  296. DO 109 J=1,NLIG
  297. IREF=(IDIM+1)*(IPT1.NUM(2,J)-1)
  298. XCOOR(IADR*(IDIM+1)+1)=XCOOR(IREF+1)+XVI
  299. XCOOR(IADR*(IDIM+1)+2)=XCOOR(IREF+2)+YVI
  300. IF (IDIM.GE.3) XCOOR(IADR*(IDIM+1)+3)=XCOOR(IREF+3)+ZVI
  301. XCOOR(IADR*(IDIM+1)+(IDIM+1))=XCOOR(IREF+IDIM+1)
  302. IADR=IADR+1
  303. C ON MET LE NOEUD DANS LES ELEMENTS
  304. IPT5.NUM(6,(I-1)*NLIG+J)=IADR
  305. IPT5.NUM(2,I*NLIG+J)=IADR
  306. 109 CONTINUE
  307. 108 CONTINUE
  308. IF (NLIG.EQ.1) GOTO 113
  309. C ON MET LES NOEUDS 4 DE GAUCHE ET 8 DE DROITE
  310. C CREATION DES NOEUDS
  311. IREFI=(IDIM+1)*(IPT8.NUM(2,I)-1)
  312. XVI=XCOOR(IREFI+1)-XCOOR(IREFB+1)
  313. YVI=XCOOR(IREFI+2)-XCOOR(IREFB+2)
  314. ZVI=XCOOR(IREFI+3)-XCOOR(IREFB+3)
  315. DO 115 J=1,NLIG
  316. DO 1150 K=1,2
  317. IF (K.EQ.1.AND.J.EQ.1) GOTO 1150
  318. IF (K.EQ.2.AND.J.EQ.NLIG) GOTO 1150
  319. IF (ICPR(K,J).NE.0) GOTO 116
  320. IREF=(IPT1.NUM(2*K-1,J)-1)*(IDIM+1)
  321. XCOOR(IADR*(IDIM+1)+1)=XCOOR(IREF+1)+XVI
  322. XCOOR(IADR*(IDIM+1)+2)=XCOOR(IREF+2)+YVI
  323. IF (IDIM.GE.3) XCOOR(IADR*(IDIM+1)+3)=XCOOR(IREF+3)+ZVI
  324. XCOOR(IADR*(IDIM+1)+(IDIM+1))=XCOOR(IREF+IDIM+1)
  325. IADR=IADR+1
  326. 116 CONTINUE
  327. C NOEUDS DES ELEM
  328. IF (ICPR(K,J).NE.0) GOTO 119
  329. IPT5.NUM(4*(3-K),(I-1)*NLIG+J)=IADR
  330. GOTO 1150
  331. 119 CONTINUE
  332. IPT5.NUM(4*(3-K),(I-1)*NLIG+J)=IPT5.NUM(4*(2-MOD(ICPR(K,J)-1,2)),
  333. # (ICPR(K,J)+1)/2+(I-1)*NLIG)
  334. 1150 CONTINUE
  335. 115 CONTINUE
  336. 113 CONTINUE
  337. 107 CONTINUE
  338. NBPTS=IADR
  339. SEGADJ MCOORD
  340. SEGSUP MELEME
  341. MELEME=IPT5
  342. SEGDES IPT1,IPT2,IPT3,IPT4
  343. IF (KSURF(ILCOUR).NE.6) GOTO 101
  344. C ON FAIT DES TRI6
  345. NBNN=6
  346. NBELEM=2*NUM(/2)
  347. NBREF=4
  348. NBSOUS=0
  349. SEGINI IPT1
  350. IPT1.ITYPEL=6
  351. IPT1.LISREF(1)=LISREF(1)
  352. IPT1.LISREF(2)=LISREF(2)
  353. IPT1.LISREF(3)=LISREF(3)
  354. IPT1.LISREF(4)=LISREF(4)
  355. IALT=1
  356. NBPTS=nbpts+NCOUCH*NLIG
  357. SEGADJ MCOORD
  358. DO 120 I=1,NCOUCH
  359. IREFI=(IDIM+1)*(IPT8.NUM(2,I)-1)
  360. XVI=XCOOR(IREFI+1)-XCOOR(IREFB+1)
  361. YVI=XCOOR(IREFI+2)-XCOOR(IREFB+2)
  362. ZVI=XCOOR(IREFI+3)-XCOOR(IREFB+3)
  363. DO 1200 J=1,NLIG
  364. INU=(I-1)*NLIG+J
  365. IALT=3-IALT
  366. C CREATION DU POINT SUPPLEMENTAIRE
  367. IREF=(NUM(2,J)-1)*(IDIM+1)
  368. XCOOR(IADR*(IDIM+1)+1)=XCOOR(IREF+1)+XVI
  369. XCOOR(IADR*(IDIM+1)+2)=XCOOR(IREF+2)+YVI
  370. IF (IDIM.EQ.3) XCOOR(IADR*(IDIM+1)+3)=XCOOR(IREF+3)+ZVI
  371. XCOOR(IADR*(IDIM+1)+(IDIM+1))=XCOOR(IREF+IDIM+1)
  372. IADR=IADR+1
  373. ITR1=2*INU-1
  374. ITR2=2*INU
  375. GOTO (124,125),IALT
  376. C CREATION DES TRIANGLES
  377. 124 IPT1.NUM(1,ITR1)=NUM(1,INU)
  378. IPT1.NUM(2,ITR1)=NUM(2,INU)
  379. IPT1.NUM(3,ITR1)=NUM(3,INU)
  380. IPT1.NUM(5,ITR1)=NUM(7,INU)
  381. IPT1.NUM(6,ITR1)=NUM(8,INU)
  382. IPT1.NUM(4,ITR1)=IADR
  383. IPT1.NUM(1,ITR2)=NUM(3,INU)
  384. IPT1.NUM(2,ITR2)=NUM(4,INU)
  385. IPT1.NUM(3,ITR2)=NUM(5,INU)
  386. IPT1.NUM(4,ITR2)=NUM(6,INU)
  387. IPT1.NUM(5,ITR2)=NUM(7,INU)
  388. IPT1.NUM(6,ITR2)=IADR
  389. IPT1.ICOLOR(ITR1)=ICOLOR(INU)
  390. IPT1.ICOLOR(ITR2)=ICOLOR(INU)
  391. GOTO 126
  392. 125 IPT1.NUM(1,ITR1)=NUM(1,INU)
  393. IPT1.NUM(2,ITR1)=NUM(2,INU)
  394. IPT1.NUM(3,ITR1)=NUM(3,INU)
  395. IPT1.NUM(4,ITR1)=NUM(4,INU)
  396. IPT1.NUM(5,ITR1)=NUM(5,INU)
  397. IPT1.NUM(6,ITR1)=IADR
  398. IPT1.NUM(1,ITR2)=NUM(5,INU)
  399. IPT1.NUM(2,ITR2)=NUM(6,INU)
  400. IPT1.NUM(3,ITR2)=NUM(7,INU)
  401. IPT1.NUM(4,ITR2)=NUM(8,INU)
  402. IPT1.NUM(5,ITR2)=NUM(1,INU)
  403. IPT1.NUM(6,ITR2)=IADR
  404. IPT1.ICOLOR(ITR1)=ICOLOR(INU)
  405. IPT1.ICOLOR(ITR2)=ICOLOR(INU)
  406. GOTO 126
  407. 126 CONTINUE
  408. 1200 CONTINUE
  409. 120 CONTINUE
  410. SEGSUP MELEME
  411. MELEME=IPT1
  412. GOTO 101
  413. 104 CONTINUE
  414. 101 CONTINUE
  415. SEGSUP ICPR
  416. C S'IL Y A LIEU EXAMINER LA DEGENERESCENCE (ROTATION)
  417. SEGDES IPT1
  418. IF (IFUSE.EQ.0) GOTO 63
  419. IPT5=IFUSE
  420. SEGACT IPT5,MELEME
  421. ltelq=.false.
  422. CALL FUSE(IPT5,MELEME,IRET,ltelq)
  423. SEGDES IPT5
  424. SEGSUP MELEME
  425. MELEME=IRET
  426. 63 CONTINUE
  427. CALL ECROBJ('MAILLAGE',MELEME)
  428. SEGDES MELEME,IPT8
  429. RETURN
  430. END
  431.  
  432.  
  433.  
  434.  
  435.  
  436.  
  437.  
  438.  
  439.  
  440.  
  441.  
  442.  
  443.  
  444.  
  445.  
  446.  

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