Télécharger cq2l.eso

Retour à la liste

Numérotation des lignes :

  1. C CQ2L SOURCE MAGN 18/05/16 21:15:00 9823
  2. SUBROUTINE CQ2L
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. C***********************************************************************
  6. C
  7. C Ce SP fait un decoupage en élément linéaire de QCF ou MACRO
  8. C
  9. C
  10. C
  11. C***********************************************************************
  12. -INC SMELEME
  13. -INC SMCOORD
  14. -INC CCOPTIO
  15. -INC SMLENTI
  16.  
  17. SEGMENT CARA
  18. INTEGER KM(6,NBSOU1)
  19. ENDSEGMENT
  20.  
  21. DIMENSION I12(8,43)
  22. DATA I12/
  23. C SEG2 2
  24. & 1,2,6*0, 2,3,6*0,
  25. C TRI7 3
  26. & 1,2,7,6,4*0, 2,3,4,7,4*0, 6,7,4,5,4*0,
  27. C QUA9 4
  28. & 1,2,9,8,4*0, 2,3,4,9,4*0, 9,4,5,6,4*0, 8,9,6,7,4*0,
  29. C CU27 8
  30. & 1,2,25,8,9,21,27,24, 2,3,4,25,21,10,22,27,
  31. & 4,5,6,25,22,11,23,27, 6,7,8,25,23,12,24,27,
  32. & 9,21,27,24,13,14,26,20, 21,10,22,27,14,15,16,26,
  33. & 27,22,11,23,26,16,17,18, 27,23,12,24,26,18,19,20,
  34. C PR21 6
  35. &1,2,19,6,7,16,21,18,2,3,4,19,16,8,17,21,4,5,6,19,17,9,18,21,7,16,
  36. &21,18,10,11,20,15,16,8,17,21,11,12,13,20,17,9,18,21,13,14,15,20,
  37. C TRI6 4
  38. & 1,2,6,5*0, 2,3,4,5*0, 4,5,6,5*0, 6,2,4,5*0,
  39. C PR18 8
  40. & 1,2,6,7,16,18,2*0,2,3,4,16,8,17,2*0,4,5,6,17,9,18,2*0,
  41. & 2,4,6,16,17,18,2*0,7,16,18,10,11,15,2*0,16,8,17,11,12,13,2*0,
  42. & 18,17,9,15,13,14,2*0, 16,17,18,11,13,15,2*0,
  43. C TE10 8
  44. & 1,2,6,7,4*0,7,6,8,2,4*0,7,6,8,9,4*0,7,8,9,10,4*0,
  45. & 2,3,4,8,4*0,6,5,4,9,4*0,9,2,4,8,4*0,9,2,4,6,4*0/
  46.  
  47. C Tetrahèdres macro
  48. DIMENSION IT12(8,8)
  49. DATA IT12/
  50. & 1,2,6,7,4*0 ,7,6,2,9,4*0 ,7,2,8,9,4*0 ,7,8,9,10,4*0,
  51. & 2,3,4,8,4*0 ,6,5,4,9,4*0 ,9,2,4,8,4*0 ,9,2,4,6,4*0/
  52. C pyramide macro
  53. DIMENSION IP12(8,10)
  54. DATA IP12/
  55. & 1,2,14,8,9,3*0, 2,3,4,14,10,3*0, 4,5,6,14,11,3*0,
  56. & 6,7,8,14,12,3*0, 9,10,11,12,13,3*0, 9,10,11,12,14,3*0,
  57. & 2,14,10,9,4*0, 4,14,10,11,4*0, 6,11,14,12,4*0, 9,10,14,12,4*0/
  58.  
  59. DIMENSION KTA(11,5)
  60. DATA KTA/3,7,11,33,34,35,36,6 ,40,24,26,
  61. & 2,8,8 ,14,14,23,25,4 ,16,23,25,
  62. C NBNN (des linéaires)
  63. & 2, 4, 4, 8, 8, 4, 5, 3, 6, 4, 5,
  64. C nb d'éléments du découpage
  65. & 2, 3, 4, 8, 6, 8, 6, 4, 8, 8, 8,
  66. C IDEC seg3 tri7 qua9 cu27 pr21 te15 py19 tri6 pr18 te10 py14
  67. & 0, 2, 5, 9, 17, 00, 00, 23, 27, 00, 00/
  68.  
  69. C SEG3 TRI7 QUA9 CU27 PR21 TE15 PY19 TRI6 PR18 TE10 PY14
  70. C 3 7 11 33 34 35 36 6 40 24 ??
  71. C SEG2 QUA4 QUA4 CUB8 CUB8 TET4 PYR5 TRI3 PRI6 TET4 PYR5
  72. C 2 8 8 14 14 23 25 4 16 23 25
  73.  
  74. C SEG3 TRI6 QUA8 CU20 PR15 TE10 PY13
  75. C 3 6 10 15 17 24 26
  76.  
  77. C*************************************************************
  78.  
  79. C write(6,*)' I12 '
  80. C do 460 l=1,35
  81. C write(6,1001)(I12(k,l),k=1,8)
  82. C460 continue
  83. C write(6,*)' CQ2L alias decl '
  84.  
  85. CALL LIROBJ('MAILLAGE',MELEME,1,IRET)
  86. IF(IRET.EQ.0)RETURN
  87.  
  88. SEGACT MELEME
  89.  
  90. NBSOU1=LISOUS(/1)
  91. IF(NBSOU1.EQ.0)NBSOU1=1
  92. SEGINI CARA
  93. NBELT=0
  94. DO 11 L=1,NBSOU1
  95. IPT1=MELEME
  96. IF(NBSOU1.NE.1)IPT1=LISOUS(L)
  97. SEGACT IPT1
  98. ITYP=IPT1.ITYPEL
  99. C On vérifie la possibilité de l'opération
  100. IK=0
  101. DO 111 I=1,11
  102. IF(ITYP.EQ.KTA(I,1))IK=I
  103. 111 CONTINUE
  104. C write(6,*)' ityp=',ityp,' IK=',IK
  105.  
  106. IF(IK.EQ.0)THEN
  107. CALL ERREUR(29)
  108. ENDIF
  109.  
  110. NBELEM=IPT1.NUM(/2)
  111. NBELT=NBELT+NBELEM
  112. KM(1,L)=NBELEM
  113. KM(3,L)=IK
  114. 11 CONTINUE
  115. C write(6,*)' NBELEM=',nbelt,' IK=',ik
  116.  
  117. NK=0
  118. DO 1 L=1,NBSOU1
  119. IPT1=MELEME
  120. IF(NBSOU1.NE.1)IPT1=LISOUS(L)
  121. SEGACT IPT1
  122. C write(6,*)' MELEME,IPT1=',MELEME,IPT1
  123. ITYP=IPT1.ITYPEL
  124.  
  125. NBEL =KM(1,L)
  126. IK =KM(3,L)
  127.  
  128. IF(IK.EQ.7)THEN
  129. NBNN =4
  130. NBELEM=4*NBEL
  131. NBSOUS=0
  132. NBREF=0
  133. SEGINI IPT5
  134. C write(6,*)' NBELEM,NBNN=',NBELEM,NBNN,' NBEL=',nbel
  135. KM(5,L)=IPT5
  136. IPT5.ITYPEL=23
  137. ENDIF
  138.  
  139. IDEC =KTA(IK,5)
  140. NP =IPT1.NUM(/1)
  141. NBNN =KTA(IK,3)
  142. NBELEM=KTA(IK,4)*NBEL
  143. NBSOUS=0
  144. NBREF=0
  145. SEGINI IPT2
  146. C write(6,*)' NBELEM,NBNN=',NBELEM,NBNN,' NBEL=',nbel
  147. KM(2,L)=IPT2
  148. IPT2.ITYPEL=KTA(IK,2)
  149. NK=0
  150. NK3=0
  151. DO 33 K=1,NBEL
  152. DO 331 M=1,KTA(IK,4)
  153. NK=NK+1
  154. NK3=NK3+1
  155. C write(6,*)' NK=',nk,'M=',M,'IDEC=',IDEC,'nbnn=',nbnn
  156.  
  157. IF(IK.EQ.10)THEN
  158. DO 333 I=1,NBNN
  159. IPT2.NUM(I,NK)=IPT1.NUM(IT12(I,M),K)
  160. 333 CONTINUE
  161. ENDIF
  162. IF(IK.EQ.7)THEN
  163. DO 334 I=1,NBNN
  164. IPT2.NUM(I,NK)=IPT1.NUM(IP12(I,M),K)
  165. 334 CONTINUE
  166. IF(M.LE.4)THEN
  167. DO 335 I=1,(NBNN-1)
  168. IPT5.NUM(I,NK3)=IPT1.NUM(IP12(I,M+6),K)
  169. 335 CONTINUE
  170. ENDIF
  171. ENDIF
  172. IF(IK.NE.10.AND.IK.NE.7)THEN
  173. DO 332 I=1,NBNN
  174. IPT2.NUM(I,NK)=IPT1.NUM(I12(I,M+IDEC),K)
  175. 332 CONTINUE
  176. ENDIF
  177.  
  178. 331 CONTINUE
  179. 33 CONTINUE
  180. 1 CONTINUE
  181.  
  182. SEGDES IPT1,IPT2
  183. IF(IK.EQ.7)THEN
  184. SEGDES IPT5
  185. ENDIF
  186.  
  187. IF(NBSOU1.EQ.1.AND.IK.NE.7)THEN
  188. IPT3=KM(2,1)
  189. ELSE
  190. NBSOUS=NBSOU1
  191. IF(IK.EQ.7)NBSOUS=NBSOUS+NBSOU1
  192. NBELEM=0
  193. NBNN=0
  194. NBREF=0
  195. SEGINI IPT3
  196. DO 785 L=1,NBSOU1
  197. IPT3.LISOUS(L)=KM(2,L)
  198. 785 CONTINUE
  199.  
  200. IF(IK.EQ.7)THEN
  201. DO 786 L=1,NBSOU1
  202. LL=L+NBSOU1
  203. IPT3.LISOUS(LL)=KM(5,L)
  204. 786 CONTINUE
  205. ENDIF
  206.  
  207. SEGDES IPT3
  208. ENDIF
  209.  
  210. CALL ECROBJ('MAILLAGE',IPT3)
  211.  
  212. RETURN
  213. 1011 FORMAT('L=',I3,4X,15(1X,I5))
  214. 1001 FORMAT(20(1X,I5))
  215. END
  216.  
  217.  
  218.  
  219.  

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