Télécharger menvlp.eso

Retour à la liste

Numérotation des lignes :

  1. C MENVLP SOURCE BP208322 16/11/18 21:19:13 9177
  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. SEGDES IPT1
  113. 10 CONTINUE
  114. SEGDES MELEMQ
  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. SEGDES MCHPOI,MSOUPO
  146.  
  147. C write(6,*)'NBFACE=',NBFACE,' NBFCE=',NBFCE
  148. NBSOUS=0
  149. NBREF=0
  150. NBNN=1
  151. NBELEM=NBFACE
  152. SEGINI MELEM1
  153. MELEM1.ITYPEL=1
  154. I1=0
  155. DO 3 K=1,LECT(/1)
  156. IF(LECT(K).NE.1)GO TO 3
  157. I1=I1+1
  158. MELEM1.NUM(1,I1)=K
  159. 3 CONTINUE
  160.  
  161. SEGSUP MLENTI
  162. CALL KRIPAD(MELEM1,MLENTI)
  163.  
  164. NBSOUS=0
  165. NBREF=0
  166. NBNN=1
  167. NBN1=0
  168. NBELEM=NBFACE
  169. SEGINI IPT0
  170. IPT0.ITYPEL=1
  171.  
  172. NBNN=3
  173. NBN3=0
  174. NBELEM=NBFACE
  175. SEGINI IPT3
  176. IPT3.ITYPEL=3
  177.  
  178. NBNN=7
  179. NBN7=0
  180. NBELEM=NBFACE
  181. SEGINI IPT7
  182. IPT7.ITYPEL=7
  183.  
  184. NBNN=9
  185. NBN9=0
  186. NBELEM=NBFACE
  187. SEGINI IPT9
  188. IPT9.ITYPEL=11
  189.  
  190. NBN0=0
  191.  
  192. SEGACT MELEMQ
  193.  
  194. DO 51 L=1,MAX(1,MELEMQ.LISOUS(/1))
  195. IPT1=MELEMQ
  196. IF(MELEMQ.LISOUS(/1).NE.0)IPT1=MELEMQ.LISOUS(L)
  197. SEGACT IPT1
  198. NP=IPT1.NUM(/1)
  199. NBEL=IPT1.NUM(/2)
  200. NOM0=NOMS(IPT1.ITYPEL)//' '
  201. CALL KALPBG(NOM0,'FONFORM ',IZFFM)
  202. SEGACT IZFFM*MOD
  203. IZHR=KZHR(1)
  204. IZH2=KZHR(2)
  205. IZF1=KTP(1)
  206. SEGACT IZHR*MOD
  207. NES=GR(/1)
  208. NPG=GR(/3)
  209. C write(6,*)' NP,NBEL=',NP,NBEL
  210. NPFA=0
  211. IF(NP.EQ.3)NPFA=1
  212. IF(NP.EQ.7)NPFA=2
  213. IF(NP.EQ.9)NPFA=3
  214. IF(NP.EQ.27)NPFA=4
  215. IF(NP.EQ.21)NPFA=5
  216. IF(NP.EQ.15)NPFA=6
  217. IF(NP.EQ.19)NPFA=7
  218. C NBPFA nb de pts face dans un element diff nb de points par face
  219. NBPFA=KTA(NPFA,1)
  220. DO 52 K=1,NBEL
  221. DO 53 I=1,NBPFA
  222. IFA=IPT1.NUM(JNF(I,NPFA),K)
  223. IF(LECT(IFA).EQ.0)GO TO 53
  224. NBPPFA=KNPF(I,NPFA)
  225. IP=KNF(NBPPFA)
  226. C write(6,*)'IPT1=',IPT1,(IPT1.NUM(ii,K),ii=1,np),' IFA=',ifa
  227.  
  228. NBN0=NBN0+1
  229. IGEOM.NUM(1,NBN0)=IFA
  230. GO TO(501,503,507,509),IP
  231. C POI1
  232. 501 CONTINUE
  233. NBN1=NBN1+1
  234. IDC3=KTA(NPFA,3)
  235. DO 511 J=1,NBPPFA
  236. J1=INF(J,I+IDC3)
  237. IPT0.NUM(J,NBN1)=IPT1.NUM(J1,K)
  238. 511 CONTINUE
  239. GO TO 53
  240.  
  241. C SEG3
  242. 503 CONTINUE
  243. NBN3=NBN3+1
  244. IDC3=KTA(NPFA,3)
  245. DO 543 II=1,NP
  246. J1 = IPT1.NUM(II,K)
  247. DO 553 N=1,IDIM
  248. XYZ(N,II) = XCOOR((J1-1)*(IDIM+1)+N)
  249. 553 CONTINUE
  250. 543 CONTINUE
  251. CALL CALJBR(FN,GR,PG,XYZ,HR,PGSQ,RPG,
  252. & NES,IDIM,NP,NPG,IAXI,AIRE,AJ,SGN)
  253.  
  254. VPOCHA(NBN0,1)=SGN
  255.  
  256. IF(SGN.EQ.1.D0)THEN
  257. JDEB=1
  258. JFIN=NBPPFA
  259. IPAS=1
  260. ELSE
  261. JDEB=NBPPFA
  262. JFIN=1
  263. IPAS=-1
  264. ENDIF
  265. J0=0
  266. DO 513 J=JDEB,JFIN,IPAS
  267. J0=J0+1
  268. J1=INF(J,I+IDC3)
  269. IPT3.NUM(J0,NBN3)=IPT1.NUM(J1,K)
  270. 513 CONTINUE
  271. GO TO 53
  272.  
  273. C TRI7
  274. 507 CONTINUE
  275. NBN7=NBN7+1
  276. IDC3=KTA(NPFA,3)
  277. DO 547 II=1,NP
  278. J1 = IPT1.NUM(II,K)
  279. DO 557 N=1,IDIM
  280. XYZ(N,II) = XCOOR((J1-1)*(IDIM+1)+N)
  281. 557 CONTINUE
  282. 547 CONTINUE
  283. CALL CALJBR(FN,GR,PG,XYZ,HR,PGSQ,RPG,
  284. & NES,IDIM,NP,NPG,IAXI,AIRE,AJ,SGN)
  285.  
  286. VPOCHA(NBN0,1)=SGN
  287.  
  288. IF(SGN.EQ.1.D0)THEN
  289. JDEB=2
  290. JFIN=NBPPFA-1
  291. IPAS=1
  292. ELSE
  293. JDEB=NBPPFA-1
  294. JFIN=2
  295. IPAS=-1
  296. ENDIF
  297. J0=1
  298. DO 517 J=JDEB,JFIN,IPAS
  299. J0=J0+1
  300. J1=INF(J,I+IDC3)
  301. IPT7.NUM(J0,NBN7)=IPT1.NUM(J1,K)
  302. 517 CONTINUE
  303. J1=INF(1,I+IDC3)
  304. IPT7.NUM(1,NBN7)=IPT1.NUM(J1,K)
  305. J1=INF(7,I+IDC3)
  306. IPT7.NUM(7,NBN7)=IPT1.NUM(J1,K)
  307. C write(6,*)(IPT7.NUM(J,NBN7),j=1,NBPPFA)
  308. GO TO 53
  309.  
  310. C QUA9
  311. 509 CONTINUE
  312. NBN9=NBN9+1
  313. IDC3=KTA(NPFA,3)
  314. DO 549 II=1,NP
  315. J1 = IPT1.NUM(II,K)
  316. DO 559 N=1,IDIM
  317. XYZ(N,II) = XCOOR((J1-1)*(IDIM+1)+N)
  318. 559 CONTINUE
  319. 549 CONTINUE
  320. CALL CALJBR(FN,GR,PG,XYZ,HR,PGSQ,RPG,
  321. & NES,IDIM,NP,NPG,IAXI,AIRE,AJ,SGN)
  322.  
  323. VPOCHA(NBN0,1)=SGN
  324.  
  325. IF(SGN.EQ.1.D0)THEN
  326. JDEB=2
  327. JFIN=NBPPFA-1
  328. IPAS=1
  329. ELSE
  330. JDEB=NBPPFA-1
  331. JFIN=2
  332. IPAS=-1
  333. ENDIF
  334. J0=1
  335. DO 519 J=JDEB,JFIN,IPAS
  336. J0=J0+1
  337. J1=INF(J,I+IDC3)
  338. IPT9.NUM(J0,NBN9)=IPT1.NUM(J1,K)
  339. 519 CONTINUE
  340. J1=INF(1,I+IDC3)
  341. IPT9.NUM(1,NBN9)=IPT1.NUM(J1,K)
  342. J1=INF(9,I+IDC3)
  343. IPT9.NUM(9,NBN9)=IPT1.NUM(J1,K)
  344. GO TO 53
  345.  
  346. 53 CONTINUE
  347. 52 CONTINUE
  348. SEGDES IPT1
  349. SEGSUP IZFFM,IZHR,IZH2,IZF1
  350. 51 CONTINUE
  351. SEGDES MELEMQ
  352.  
  353. NBS=0
  354. CALL INITI(ITAB,4,0)
  355.  
  356. IF(NBN1.NE.0)THEN
  357. NBS=NBS+1
  358. NBNN=1
  359. NBELEM=NBN1
  360. SEGADJ IPT0
  361. ITAB(NBS)=IPT0
  362. MENVEL=IPT0
  363. ENDIF
  364.  
  365. IF(NBN3.NE.0)THEN
  366. NBS=NBS+1
  367. NBNN=3
  368. NBELEM=NBN3
  369. SEGADJ IPT3
  370. ITAB(NBS)=IPT3
  371. MENVEL=IPT3
  372. ENDIF
  373.  
  374. IF(NBN7.NE.0)THEN
  375. NBS=NBS+1
  376. NBNN=7
  377. NBELEM=NBN7
  378. SEGADJ IPT7
  379. ITAB(NBS)=IPT7
  380. MENVEL=IPT7
  381. ENDIF
  382.  
  383. IF(NBN9.NE.0)THEN
  384. NBS=NBS+1
  385. NBNN=9
  386. NBELEM=NBN9
  387. SEGADJ IPT9
  388. ITAB(NBS)=IPT9
  389. MENVEL=IPT9
  390. ENDIF
  391.  
  392. IF(NBS.NE.1)THEN
  393. NBSOUS=NBS
  394. NBREF=0
  395. NBNN=0
  396. NBELEM=0
  397. SEGINI MENVEL
  398. DO 60 L=1,NBS
  399. MENVEL.LISOUS(L)=ITAB(L)
  400. 60 CONTINUE
  401. ENDIF
  402. SEGSUP MLENTI,MELEM1
  403.  
  404. C Creation du Chamelem d'orientation
  405. CALL KRIPAD(IGEOM,MLENTI)
  406. SEGACT MENVEL
  407.  
  408. DO 11 L=1,MAX(1,MENVEL.LISOUS(/1))
  409. IPT1=MENVEL
  410. IF(MENVEL.LISOUS(/1).NE.0)IPT1=MENVEL.LISOUS(L)
  411. SEGACT IPT1
  412. NP=IPT1.NUM(/1)
  413. NBEL=IPT1.NUM(/2)
  414.  
  415. NOM0=NOMS(IPT1.ITYPEL)//' '
  416. CALL KALPBG(NOM0,'FONFORM ',IZFFM)
  417. SEGACT IZFFM*MOD
  418. IZHR=KZHR(1)
  419. IZH2=KZHR(2)
  420. IZF1=KTP(1)
  421. SEGACT IZHR*MOD,IZF1*MOD
  422. NES=GR(/1)
  423. NPG=GR(/3)
  424.  
  425. IFA=NP
  426. IF(NP.EQ.3)IFA=2
  427.  
  428. DO 23 K=1,NBEL
  429. I1=LECT(IPT1.NUM(IFA,K))
  430. IF(I1.EQ.0)GO TO 23
  431. SJ=VPOCHA(I1,1)
  432.  
  433. DO 30 I=1,NP
  434. J1 = IPT1.NUM(I,K)
  435. DO 31 N=1,IDIM
  436. XYZ(N,I) = XCOOR((J1-1)*(IDIM+1)+N)
  437. 31 CONTINUE
  438. 30 CONTINUE
  439. CALL CALJBR(FN,GR,PG,XYZ,HR,PGSQ,RPG,
  440. & NES,IDIM,NP,NPG,IAXI,AIRE,AJ,ASGN)
  441.  
  442. DO 33 N=1,IDIM
  443. C VPOCHA(I1,N)=AJ(N,IDIM,1)*SJ
  444. VPOCHA(I1,N)=AJ(N,IDIM,1)
  445. 33 CONTINUE
  446.  
  447. 23 CONTINUE
  448.  
  449. 21 CONTINUE
  450. SEGDES IPT1
  451. SEGSUP IZFFM,IZHR,IZH2,IZF1
  452. 11 CONTINUE
  453. SEGSUP MLENTI
  454. SEGDES IGEOM,MPOVAL,MENVEL
  455. C write(6,*)'FIN MENVLP'
  456.  
  457. RETURN
  458. 1001 FORMAT(20(1X,I5))
  459. 1002 FORMAT(10(1X,1PE11.4))
  460. END
  461.  
  462.  
  463.  
  464.  
  465.  
  466.  
  467.  
  468.  
  469.  

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