Télécharger cq2l.eso

Retour à la liste

Numérotation des lignes :

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

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