Télécharger menvlp.eso

Retour à la liste

Numérotation des lignes :

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

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