Télécharger kcot.eso

Retour à la liste

Numérotation des lignes :

  1. C KCOT SOURCE BP208322 16/11/18 21:18:02 9177
  2. SUBROUTINE KCOT
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. C*************************************************************************
  6. C
  7. C OBJET : Cree un CHAMPOINT CENTRE contenant les informations
  8. C décrites ci dessous, sur les éléments du domaine.
  9. C
  10. C SYNTAXE : CHPC = KCOT OBJDOM ;
  11. C
  12. C OBJDOM : TABLE de SOUSTYPE DOMAINE
  13. C
  14. C AVIS IMPORTANT ;
  15. C
  16. C Ces informations sont destinées aux opérateurs de discrétisation
  17. C et sont rangées dans un ordre particulier.
  18. C
  19. C Les dimensions du tableau sont : (DIME NBEL) DIME=11 en 2D
  20. C DIME=13 en 3D
  21. C et il contient :
  22. C
  23. C pour un SEG2 la longueur de l'element (XML) et la matrice P(2,2) en 2D
  24. C P(3,3) en 3D
  25. C pour un TRI3 XML,XMH,AJ1/XML,AJ2/XML, et la matrice P(2,2) en 2D
  26. C P(3,3) en 3D
  27. C pour un QUA4 IDEM
  28. C pour un CUB8 XML XMH XME et la matrice P
  29. C pour un PRI6 IDEM
  30. C
  31. C***********************************************************************
  32. C MATRICE P
  33. C LA MATRICE DE ROTATION DU REPERE GLOBALE VERS LE REPERE LOCAL
  34. C DEFINI PAR DEUX OU TROIS POINTS PRIS DANS XYZ SUIVANT QU'ON EST
  35. C EN 2D OU EN 3D
  36. C ON PREND P1 P2 ET PNP
  37. C
  38. C U TEL QUE T SOIT DIRIGE SUIVANT P1P2 V TOURNE VERS
  39. C . .V P1PNP ET U = T VECTORIEL V
  40. C . .
  41. C . . __ __
  42. C (P1). . . . .T (P2) | tx ty tz |
  43. C | |
  44. C ON A ALORS WL= P WG P = | vx vy vz |
  45. C | |
  46. C | ux uy uz |
  47. C |__ __|
  48. C*************************************************************************
  49. -INC CCOPTIO
  50. -INC CCGEOME
  51. -INC SMTABLE
  52. -INC SMELEME
  53. POINTEUR MELEMC.MELEME
  54. -INC SMCOORD
  55. -INC SMCHPOI
  56. -INC SIZFFB
  57. PARAMETER (NLTS=8)
  58. CHARACTER*8 LISTS(NLTS)
  59. C***
  60. REAL*8 AAJ(3,3,9),U,XC(3),T(13),XQ(81)
  61. PARAMETER (NTB=1)
  62. CHARACTER*8 LTAB(NTB),TYPE,NOM0,TYPC
  63. DIMENSION KTAB(NTB)
  64. DATA LTAB/'DOMAINE '/
  65. DATA LISTS/'QUA4 ','CUB8 ','TRI3 ','PRI6 ','SEG2 ',
  66. &'SEG3 ','QUA9 ','TRI7 '/
  67. C***
  68. C write(6,*)' DBUT KCOT '
  69. NTO=NTB
  70. CALL LITABS(LTAB,KTAB,NTB,NTO,IRET)
  71. IF (IERR.NE.0) RETURN
  72. MTABD=KTAB(1)
  73.  
  74. CALL INITD(AAJ,81,0.D0)
  75. TYPE=' '
  76. CALL ACMO(MTABD,'CENTRE',TYPE,MELEMC)
  77. IF(TYPE.NE.'MAILLAGE')GO TO 90
  78.  
  79. IF(IDIM.EQ.2)NC=11
  80. IF(IDIM.EQ.3)NC=13
  81.  
  82. TYPE='CENTRE'
  83. CALL CRCHPT(TYPE,MELEMC,NC,MCHPOI)
  84. CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOM)
  85.  
  86. TYPE=' '
  87. CALL ACMO(MTABD,'MAILLAGE',TYPE,MELEME)
  88. IF(TYPE.NE.'MAILLAGE')GO TO 90
  89. SEGACT MELEME
  90.  
  91. IAXI=0
  92. IF(IFOMOD.EQ.0)IAXI=2
  93. NPGI=1
  94.  
  95. NBSOUS=LISOUS(/1)
  96. IF(NBSOUS.EQ.0)NBSOUS=1
  97.  
  98. K0=0
  99. DO 1 L=1,NBSOUS
  100. IPT1=MELEME
  101. IF(NBSOUS.NE.1)IPT1=LISOUS(L)
  102. SEGACT IPT1
  103. NP=IPT1.NUM(/1)
  104. NEL=IPT1.NUM(/2)
  105. NOM0=NOMS(IPT1.ITYPEL)//' '
  106. CALL OPTLI(IP,LISTS,NOM0,NLTS)
  107. IF(IP.EQ.0)THEN
  108. WRITE(6,*)' Il y a des types d''éléments pour lesquels on ne sait'
  109. &,'pas faire'
  110. GO TO 1
  111. ENDIF
  112. CALL KALPBG(NOM0,'FONFORM ',IZFFM)
  113. SEGACT IZFFM*MOD
  114. IZHR=KZHR(1)
  115. SEGACT IZHR*MOD
  116. NES=GR(/1)
  117. NPG=GR(/3)
  118.  
  119. DO 10 K=1,NEL
  120. KK=K0+K
  121. NPGR=0
  122. IF(IAXI.NE.0)NPGR=NPG
  123. C
  124. C REMPLISSAGE DE XYZ
  125. C ------------------
  126. C
  127. DO 12 I=1,NP
  128. J=IPT1.NUM(I,K)
  129. DO 12 N=1,IDIM
  130. XYZ(N,I)=XCOOR((J-1)*(IDIM+1)+N)
  131. 12 CONTINUE
  132.  
  133. IF(IP.EQ.6)THEN
  134. IN=0
  135. DO 13 I=1,NP,2
  136. J=IPT1.NUM(I,K)
  137. DO 13 N=1,IDIM
  138. IN=IN+1
  139. XQ(IN)=XCOOR((J-1)*(IDIM+1)+N)
  140. 13 CONTINUE
  141. ELSEIF(IP.GT.6)THEN
  142. IN=0
  143. DO 14 I=1,NP-1,2
  144. J=IPT1.NUM(I,K)
  145. DO 14 N=1,IDIM
  146. IN=IN+1
  147. XQ(IN)=XCOOR((J-1)*(IDIM+1)+N)
  148. 14 CONTINUE
  149. ENDIF
  150.  
  151. IF(IP.LE.5)CALL CALJAJ(GR,XYZ,NES,IDIM,NP,NPGI,AAJ)
  152. C
  153. CALL CALJBC(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,IDIM,NP,NPG,IAXI,AIRE)
  154.  
  155. IF(AIRE.LE.0)AIRE=ABS(AIRE)
  156.  
  157.  
  158. C CALCUL DES LONGUEURS DES COTES DE L'ELEMENT
  159. C UNIQUEMENT POUR LES SEG2 QUA4 ET CUB8
  160.  
  161. XML=0.D0
  162. DO 231 N=1,IDIM
  163. XML=XML+(XYZ(N,1)-XYZ(N,2))*(XYZ(N,1)-XYZ(N,2))
  164. 231 CONTINUE
  165. XML=SQRT(XML)
  166. C
  167. C
  168. IF(XML.EQ.0.D0)
  169. &WRITE(6,*)' ELEMENT DEGENERE ( AYANT UN COTE DE LONGUEUR NULLE) '
  170. C
  171. C
  172. IF(NOM0.EQ.'SEG2 ')THEN
  173. T(1)=XML
  174. CALL CALJQB(XYZ,T(5),IDIM,IDIM)
  175. GOTO 244
  176. ELSEIF(NOM0.EQ.'SEG3 ')THEN
  177. T(1)=XML
  178. CALL CALJQB(XQ,T(5),IDIM,IDIM)
  179. GOTO 244
  180. ENDIF
  181. C
  182. C
  183. XMH=0.D0
  184. DO 232 N=1,IDIM
  185. XMH=XMH+(XYZ(N,2)-XYZ(N,3))*(XYZ(N,2)-XYZ(N,3))
  186. 232 CONTINUE
  187. XMH=SQRT(XMH)
  188. C WRITE(6,*)'........XML XMH NP NES ',XML,XMH,NP,NES
  189.  
  190. C
  191. C
  192. IF(XMH.EQ.0.D0)
  193. &WRITE(6,*)' ELEMENT DEGENERE ( AYANT UN COTE DE LONGUEUR NULLE) '
  194. C
  195. C
  196.  
  197. IF(NOM0.EQ.'QUA4 '.OR.NOM0.EQ.'TRI3 ')THEN
  198. T(1)=XML
  199. T(2)=XMH
  200. T(3)=AAJ(1,1,1)/XML
  201. T(4)=AAJ(2,1,1)/XML
  202. CALL CALJQB(XYZ,T(5),IDIM,IDIM)
  203. GOTO 244
  204. ELSEIF(NOM0.EQ.'QUA9 '.OR.NOM0.EQ.'TRI7 ')THEN
  205. T(1)=XML
  206. T(2)=XMH
  207. T(3)=AAJ(1,1,1)/XML
  208. T(4)=AAJ(2,1,1)/XML
  209. CALL CALJQB(XQ,T(5),IDIM,IDIM)
  210. GOTO 244
  211. ENDIF
  212.  
  213. IF(NOM0.EQ.'CUB8 '.OR.NOM0.EQ.'PRI6 ')THEN
  214.  
  215. XME=0.D0
  216. IF(NOM0.EQ.'CUB8 ')THEN
  217. DO 242 N=1,IDIM
  218. XME=XME+(XYZ(N,1)-XYZ(N,5))*(XYZ(N,1)-XYZ(N,5))
  219. 242 CONTINUE
  220. ENDIF
  221.  
  222. IF(NOM0.EQ.'PRI6 ')THEN
  223. DO 243 N=1,IDIM
  224. XME=XME+(XYZ(N,1)-XYZ(N,4))*(XYZ(N,1)-XYZ(N,4))
  225. 243 CONTINUE
  226. ENDIF
  227.  
  228. XME=SQRT(XME)
  229. C WRITE(6,*)'........XML XMH XME NP NES ',XML,XMH,XME,NP,NES
  230. C
  231. IF(XME.EQ.0.D0)
  232. &WRITE(6,*)' ELEMENT DEGENERE ( AYANT UN COTE DE LONGUEUR NULLE) '
  233. C
  234. C
  235. CALL CALJQB(XYZ,T(5),IDIM,4)
  236. T(1)=XML
  237. T(2)=XMH
  238. T(3)=XME
  239. GO TO 244
  240. ENDIF
  241.  
  242. 244 CONTINUE
  243.  
  244. CALL RSETIV(VPOCHA,NC,KK,T,NC)
  245.  
  246. C write(6,*)' KK=',KK
  247. C write(6,1002)T
  248. 10 CONTINUE
  249. K0=K0+NEL
  250. SEGDES IPT1
  251. 1 CONTINUE
  252. SEGDES MELEME,MPOVAL,MCHPOI
  253. C
  254. CALL ECROBJ('CHPOINT ',MCHPOI)
  255.  
  256. C write(6,*)' FIN KCOT '
  257. RETURN
  258.  
  259. 90 CONTINUE
  260. WRITE(6,*)' Interruption anormale de KCOT'
  261. C Option %m1:8 incompatible avec les données
  262. CALL ERREUR(803)
  263. RETURN
  264. 1001 FORMAT(20(1X,I5))
  265. 1002 FORMAT(10(1X,1PE11.4))
  266. END
  267.  
  268.  
  269.  
  270.  
  271.  
  272.  
  273.  
  274.  
  275.  

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