Télécharger menvlp.eso

Retour à la liste

Numérotation des lignes :

  1. C MENVLP SOURCE PV 20/03/30 21:21:06 10567
  2. SUBROUTINE MENVLP(MELEMQ,MENVEL,MCHPOI,IRET)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5.  
  6.  
  7. -INC PPARAM
  8. -INC CCOPTIO
  9. -INC SMLENTI
  10. -INC CCGEOME
  11. -INC SIZFFB
  12. POINTEUR IZF1.IZFFM,IZH2.IZHR
  13. -INC SMCOORD
  14. -INC SMCHPOI
  15. -INC SMELEME
  16. POINTEUR MENVEL.MELEME,MELEMP.MELEME,MELEM1.MELEME
  17. POINTEUR MELEMQ.MELEME
  18. POINTEUR IPT0.MELEME,IGEOM.MELEME
  19. CHARACTER*8 NOM0,TYPE
  20.  
  21. DIMENSION JNF(6,7),KTA(7,3),ITAB(4)
  22. DIMENSION KNPF(6,7),KNF(9)
  23.  
  24. DATA KTA/
  25. C nb de faces par type d'élément
  26. & 2, 3, 4, 6, 5, 4, 5,
  27. C numero type elt pour conectivités
  28. & 3, 7,11,33,34,35,36,
  29. C Idc3
  30. & 0, 2,5 ,9 ,15 ,20,24/
  31.  
  32.  
  33. C Numero des pts faces SEG3 TRI7 QUA9 CU27 PR21 TE15 PY19
  34.  
  35. DATA JNF/1,3,0,0,0,0,
  36. & 2,4,6,0,0,0, 2,4,6,8,0,0,
  37. & 25,26,21,22,23,24, 19,20,16,17,18,0,
  38. & 12,11,13,14,0,0, 14,15,16,17,18,0/
  39.  
  40. C Nombre de points par face SEG3 TRI7 QUA9 CU27 PR21 TE15 PY19
  41.  
  42. DATA KNPF/1,1,0,0,0,0,
  43. & 3,3,3,0,0,0, 3,3,3,3,0,0,
  44. & 9,9,9,9,9,9, 7,7,9,9,9,0,
  45. & 7,7,7,7,0,0, 9,7,7,7,7,0/
  46.  
  47. DATA KNF/1,0,2,0,0,0,3,0,4/
  48.  
  49.  
  50. DIMENSION INF(9,29)
  51. C SEG3
  52. DATA INF/
  53. & 1,0,0,0,0,0,0,0,0, 3,0,0,0,0,0,0,0,0,
  54. C TRI7
  55. & 3,2,1,0,0,0,0,0,0, 5,4,3,0,0,0,0,0,0, 1,6,5,0,0,0,0,0,0,
  56. C QUA9
  57. & 3,2,1,0,0,0,0,0,0, 5,4,3,0,0,0,0,0,0, 7,6,5,0,0,0,0,0,0,
  58. & 1,8,7,0,0,0,0,0,0,
  59. C CU27
  60. & 1,8,7,6,5,4,3,2,25, 13,14,15,16,17,18,19,20,26,
  61. & 1,2,3,10,15,14,13,9,21, 3,4,5,11,17,16,15,10,22,
  62. & 5,6,7,12,19,18,17,11,23, 7,8,1,9,13,20,19,12,24,
  63. C PR21
  64. & 1,6,5,4,3,2,19,0,0, 10,11,12,13,14,15,20,0,0,
  65. & 1,2,3,8 ,12,11,10,7,16, 3,4,5,9 ,14,13,12,8 ,17,
  66. & 5,6,1,7,10,15,14,9 ,18,
  67. C TE15
  68. & 1,2,3,8,10,7,12,0,0, 1,6,5,4,3,2,11,0,0, 3,4,5,9,10,8,13,0,0,
  69. & 1,7,10,9,5,6,14,0,0,
  70. C PY19
  71. & 1,8,7,6,5,4,3,2,14, 1,2,3,10,13,9,15,0,0, 3,4,5,11,13,10,16,0,0,
  72. & 5,6,7,12,13,11,17,0,0, 7,8,1,9,13,12,18,0,0/
  73.  
  74. C write(6,*)'DEBUT MENVLP'
  75. IRET=1
  76.  
  77. IAXI=0
  78. IF(IFOMOD.EQ.0)IAXI=2
  79.  
  80. JG=nbpts
  81. SEGINI MLENTI
  82.  
  83. NBFCE=0
  84.  
  85. SEGACT MELEMQ
  86.  
  87. DO 10 L=1,MAX(1,MELEMQ.LISOUS(/1))
  88. IPT1=MELEMQ
  89. IF(MELEMQ.LISOUS(/1).NE.0)IPT1=MELEMQ.LISOUS(L)
  90. SEGACT IPT1
  91. NP=IPT1.NUM(/1)
  92. NBEL=IPT1.NUM(/2)
  93.  
  94. NPFA=0
  95. IF(NP.EQ.3)NPFA=1
  96. IF(NP.EQ.7)NPFA=2
  97. IF(NP.EQ.9)NPFA=3
  98. IF(NP.EQ.27)NPFA=4
  99. IF(NP.EQ.21)NPFA=5
  100. IF(NP.EQ.15)NPFA=6
  101. IF(NP.EQ.19)NPFA=7
  102.  
  103. C NBPFA nb de pts face dans un element diff nb de points par face
  104. NBPFA=KTA(NPFA,1)
  105.  
  106. DO 1 K=1,NBEL
  107.  
  108. DO 1 I=1,NBPFA
  109. J=JNF(I,NPFA)
  110. IFA=IPT1.NUM(J,K)
  111. NBFCE=NBFCE+1
  112. LECT(IFA)=LECT(IFA)+1
  113. 1 CONTINUE
  114. 10 CONTINUE
  115.  
  116. NBFACE =0
  117.  
  118. DO 2 K=1,LECT(/1)
  119. IF(LECT(K).NE.1)GO TO 2
  120. NBFACE=NBFACE+1
  121. 2 CONTINUE
  122.  
  123. C Tracage orientation des faces
  124. NBSOUS=0
  125. NBREF=0
  126. NBNN=1
  127. NBELEM=NBFACE
  128. SEGINI IGEOM
  129.  
  130. NSOUPO=1
  131. NAT=1
  132. NC=IDIM
  133. N=NBFACE
  134. SEGINI MCHPOI,MSOUPO,MPOVAL
  135. JATTRI(1)=2
  136. IFOPOI=IFOMOD
  137. MTYPOI=' '
  138. MOCHDE=' '
  139. IPCHP(1)=MSOUPO
  140. IGEOC=IGEOM
  141. IPOVAL=MPOVAL
  142. NOCOMP(1)='UX'
  143. NOCOMP(2)='UY'
  144. IF(IDIM.EQ.3)NOCOMP(3)='UZ'
  145.  
  146. C write(6,*)'NBFACE=',NBFACE,' NBFCE=',NBFCE
  147. NBSOUS=0
  148. NBREF=0
  149. NBNN=1
  150. NBELEM=NBFACE
  151. SEGINI MELEM1
  152. MELEM1.ITYPEL=1
  153. I1=0
  154. DO 3 K=1,LECT(/1)
  155. IF(LECT(K).NE.1)GO TO 3
  156. I1=I1+1
  157. MELEM1.NUM(1,I1)=K
  158. 3 CONTINUE
  159.  
  160. SEGSUP MLENTI
  161. CALL KRIPAD(MELEM1,MLENTI)
  162.  
  163. NBSOUS=0
  164. NBREF=0
  165. NBNN=1
  166. NBN1=0
  167. NBELEM=NBFACE
  168. SEGINI IPT0
  169. IPT0.ITYPEL=1
  170.  
  171. NBNN=3
  172. NBN3=0
  173. NBELEM=NBFACE
  174. SEGINI IPT3
  175. IPT3.ITYPEL=3
  176.  
  177. NBNN=7
  178. NBN7=0
  179. NBELEM=NBFACE
  180. SEGINI IPT7
  181. IPT7.ITYPEL=7
  182.  
  183. NBNN=9
  184. NBN9=0
  185. NBELEM=NBFACE
  186. SEGINI IPT9
  187. IPT9.ITYPEL=11
  188.  
  189. NBN0=0
  190.  
  191. SEGACT MELEMQ
  192.  
  193. DO 51 L=1,MAX(1,MELEMQ.LISOUS(/1))
  194. IPT1=MELEMQ
  195. IF(MELEMQ.LISOUS(/1).NE.0)IPT1=MELEMQ.LISOUS(L)
  196. SEGACT IPT1
  197. NP=IPT1.NUM(/1)
  198. NBEL=IPT1.NUM(/2)
  199. NOM0=NOMS(IPT1.ITYPEL)//' '
  200. CALL KALPBG(NOM0,'FONFORM ',IZFFM)
  201. SEGACT IZFFM*MOD
  202. IZHR=KZHR(1)
  203. IZH2=KZHR(2)
  204. IZF1=KTP(1)
  205. SEGACT IZHR*MOD
  206. NES=GR(/1)
  207. NPG=GR(/3)
  208. C write(6,*)' NP,NBEL=',NP,NBEL
  209. NPFA=0
  210. IF(NP.EQ.3)NPFA=1
  211. IF(NP.EQ.7)NPFA=2
  212. IF(NP.EQ.9)NPFA=3
  213. IF(NP.EQ.27)NPFA=4
  214. IF(NP.EQ.21)NPFA=5
  215. IF(NP.EQ.15)NPFA=6
  216. IF(NP.EQ.19)NPFA=7
  217. C NBPFA nb de pts face dans un element diff nb de points par face
  218. NBPFA=KTA(NPFA,1)
  219. DO 52 K=1,NBEL
  220. DO 53 I=1,NBPFA
  221. IFA=IPT1.NUM(JNF(I,NPFA),K)
  222. IF(LECT(IFA).EQ.0)GO TO 53
  223. NBPPFA=KNPF(I,NPFA)
  224. IP=KNF(NBPPFA)
  225. C write(6,*)'IPT1=',IPT1,(IPT1.NUM(ii,K),ii=1,np),' IFA=',ifa
  226.  
  227. NBN0=NBN0+1
  228. IGEOM.NUM(1,NBN0)=IFA
  229. GO TO(501,503,507,509),IP
  230. C POI1
  231. 501 CONTINUE
  232. NBN1=NBN1+1
  233. IDC3=KTA(NPFA,3)
  234. DO 511 J=1,NBPPFA
  235. J1=INF(J,I+IDC3)
  236. IPT0.NUM(J,NBN1)=IPT1.NUM(J1,K)
  237. 511 CONTINUE
  238. GO TO 53
  239.  
  240. C SEG3
  241. 503 CONTINUE
  242. NBN3=NBN3+1
  243. IDC3=KTA(NPFA,3)
  244. DO 543 II=1,NP
  245. J1 = IPT1.NUM(II,K)
  246. DO 553 N=1,IDIM
  247. XYZ(N,II) = XCOOR((J1-1)*(IDIM+1)+N)
  248. 553 CONTINUE
  249. 543 CONTINUE
  250. CALL CALJBR(FN,GR,PG,XYZ,HR,PGSQ,RPG,
  251. & NES,IDIM,NP,NPG,IAXI,AIRE,AJ,SGN)
  252.  
  253. VPOCHA(NBN0,1)=SGN
  254.  
  255. IF(SGN.EQ.1.D0)THEN
  256. JDEB=1
  257. JFIN=NBPPFA
  258. IPAS=1
  259. ELSE
  260. JDEB=NBPPFA
  261. JFIN=1
  262. IPAS=-1
  263. ENDIF
  264. J0=0
  265. DO 513 J=JDEB,JFIN,IPAS
  266. J0=J0+1
  267. J1=INF(J,I+IDC3)
  268. IPT3.NUM(J0,NBN3)=IPT1.NUM(J1,K)
  269. 513 CONTINUE
  270. GO TO 53
  271.  
  272. C TRI7
  273. 507 CONTINUE
  274. NBN7=NBN7+1
  275. IDC3=KTA(NPFA,3)
  276. DO 547 II=1,NP
  277. J1 = IPT1.NUM(II,K)
  278. DO 557 N=1,IDIM
  279. XYZ(N,II) = XCOOR((J1-1)*(IDIM+1)+N)
  280. 557 CONTINUE
  281. 547 CONTINUE
  282. CALL CALJBR(FN,GR,PG,XYZ,HR,PGSQ,RPG,
  283. & NES,IDIM,NP,NPG,IAXI,AIRE,AJ,SGN)
  284.  
  285. VPOCHA(NBN0,1)=SGN
  286.  
  287. IF(SGN.EQ.1.D0)THEN
  288. JDEB=2
  289. JFIN=NBPPFA-1
  290. IPAS=1
  291. ELSE
  292. JDEB=NBPPFA-1
  293. JFIN=2
  294. IPAS=-1
  295. ENDIF
  296. J0=1
  297. DO 517 J=JDEB,JFIN,IPAS
  298. J0=J0+1
  299. J1=INF(J,I+IDC3)
  300. IPT7.NUM(J0,NBN7)=IPT1.NUM(J1,K)
  301. 517 CONTINUE
  302. J1=INF(1,I+IDC3)
  303. IPT7.NUM(1,NBN7)=IPT1.NUM(J1,K)
  304. J1=INF(7,I+IDC3)
  305. IPT7.NUM(7,NBN7)=IPT1.NUM(J1,K)
  306. C write(6,*)(IPT7.NUM(J,NBN7),j=1,NBPPFA)
  307. GO TO 53
  308.  
  309. C QUA9
  310. 509 CONTINUE
  311. NBN9=NBN9+1
  312. IDC3=KTA(NPFA,3)
  313. DO 549 II=1,NP
  314. J1 = IPT1.NUM(II,K)
  315. DO 559 N=1,IDIM
  316. XYZ(N,II) = XCOOR((J1-1)*(IDIM+1)+N)
  317. 559 CONTINUE
  318. 549 CONTINUE
  319. CALL CALJBR(FN,GR,PG,XYZ,HR,PGSQ,RPG,
  320. & NES,IDIM,NP,NPG,IAXI,AIRE,AJ,SGN)
  321.  
  322. VPOCHA(NBN0,1)=SGN
  323.  
  324. IF(SGN.EQ.1.D0)THEN
  325. JDEB=2
  326. JFIN=NBPPFA-1
  327. IPAS=1
  328. ELSE
  329. JDEB=NBPPFA-1
  330. JFIN=2
  331. IPAS=-1
  332. ENDIF
  333. J0=1
  334. DO 519 J=JDEB,JFIN,IPAS
  335. J0=J0+1
  336. J1=INF(J,I+IDC3)
  337. IPT9.NUM(J0,NBN9)=IPT1.NUM(J1,K)
  338. 519 CONTINUE
  339. J1=INF(1,I+IDC3)
  340. IPT9.NUM(1,NBN9)=IPT1.NUM(J1,K)
  341. J1=INF(9,I+IDC3)
  342. IPT9.NUM(9,NBN9)=IPT1.NUM(J1,K)
  343. GO TO 53
  344.  
  345. 53 CONTINUE
  346. 52 CONTINUE
  347. SEGSUP IZFFM,IZHR,IZH2,IZF1
  348. 51 CONTINUE
  349.  
  350. NBS=0
  351. CALL INITI(ITAB,4,0)
  352.  
  353. IF(NBN1.NE.0)THEN
  354. NBS=NBS+1
  355. NBNN=1
  356. NBELEM=NBN1
  357. SEGADJ IPT0
  358. ITAB(NBS)=IPT0
  359. MENVEL=IPT0
  360. ENDIF
  361.  
  362. IF(NBN3.NE.0)THEN
  363. NBS=NBS+1
  364. NBNN=3
  365. NBELEM=NBN3
  366. SEGADJ IPT3
  367. ITAB(NBS)=IPT3
  368. MENVEL=IPT3
  369. ENDIF
  370.  
  371. IF(NBN7.NE.0)THEN
  372. NBS=NBS+1
  373. NBNN=7
  374. NBELEM=NBN7
  375. SEGADJ IPT7
  376. ITAB(NBS)=IPT7
  377. MENVEL=IPT7
  378. ENDIF
  379.  
  380. IF(NBN9.NE.0)THEN
  381. NBS=NBS+1
  382. NBNN=9
  383. NBELEM=NBN9
  384. SEGADJ IPT9
  385. ITAB(NBS)=IPT9
  386. MENVEL=IPT9
  387. ENDIF
  388.  
  389. IF(NBS.NE.1)THEN
  390. NBSOUS=NBS
  391. NBREF=0
  392. NBNN=0
  393. NBELEM=0
  394. SEGINI MENVEL
  395. DO 60 L=1,NBS
  396. MENVEL.LISOUS(L)=ITAB(L)
  397. 60 CONTINUE
  398. ENDIF
  399. SEGSUP MLENTI,MELEM1
  400.  
  401. C Creation du Chamelem d'orientation
  402. CALL KRIPAD(IGEOM,MLENTI)
  403. SEGACT MENVEL
  404.  
  405. DO 11 L=1,MAX(1,MENVEL.LISOUS(/1))
  406. IPT1=MENVEL
  407. IF(MENVEL.LISOUS(/1).NE.0)IPT1=MENVEL.LISOUS(L)
  408. SEGACT IPT1
  409. NP=IPT1.NUM(/1)
  410. NBEL=IPT1.NUM(/2)
  411.  
  412. NOM0=NOMS(IPT1.ITYPEL)//' '
  413. CALL KALPBG(NOM0,'FONFORM ',IZFFM)
  414. SEGACT IZFFM*MOD
  415. IZHR=KZHR(1)
  416. IZH2=KZHR(2)
  417. IZF1=KTP(1)
  418. SEGACT IZHR*MOD,IZF1*MOD
  419. NES=GR(/1)
  420. NPG=GR(/3)
  421.  
  422. IFA=NP
  423. IF(NP.EQ.3)IFA=2
  424.  
  425. DO 23 K=1,NBEL
  426. I1=LECT(IPT1.NUM(IFA,K))
  427. IF(I1.EQ.0)GO TO 23
  428. SJ=VPOCHA(I1,1)
  429.  
  430. DO 30 I=1,NP
  431. J1 = IPT1.NUM(I,K)
  432. DO 31 N=1,IDIM
  433. XYZ(N,I) = XCOOR((J1-1)*(IDIM+1)+N)
  434. 31 CONTINUE
  435. 30 CONTINUE
  436. CALL CALJBR(FN,GR,PG,XYZ,HR,PGSQ,RPG,
  437. & NES,IDIM,NP,NPG,IAXI,AIRE,AJ,ASGN)
  438.  
  439. DO 33 N=1,IDIM
  440. C VPOCHA(I1,N)=AJ(N,IDIM,1)*SJ
  441. VPOCHA(I1,N)=AJ(N,IDIM,1)
  442. 33 CONTINUE
  443.  
  444. 23 CONTINUE
  445.  
  446. 21 CONTINUE
  447. SEGSUP IZFFM,IZHR,IZH2,IZF1
  448. 11 CONTINUE
  449. SEGSUP MLENTI
  450. C write(6,*)'FIN MENVLP'
  451.  
  452. RETURN
  453. 1001 FORMAT(20(1X,I5))
  454. 1002 FORMAT(10(1X,1PE11.4))
  455. END
  456.  
  457.  
  458.  
  459.  

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