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 PPARAM
  50. -INC CCOPTIO
  51. -INC CCGEOME
  52. -INC SMTABLE
  53. -INC SMELEME
  54. POINTEUR MELEMC.MELEME
  55. -INC SMCOORD
  56. -INC SMCHPOI
  57. -INC SIZFFB
  58. PARAMETER (NLTS=8)
  59. CHARACTER*8 LISTS(NLTS)
  60. C***
  61. REAL*8 AAJ(3,3,9),U,XC(3),T(13),XQ(81)
  62. PARAMETER (NTB=1)
  63. CHARACTER*8 LTAB(NTB),TYPE,NOM0,TYPC
  64. DIMENSION KTAB(NTB)
  65. DATA LTAB/'DOMAINE '/
  66. DATA LISTS/'QUA4 ','CUB8 ','TRI3 ','PRI6 ','SEG2 ',
  67. &'SEG3 ','QUA9 ','TRI7 '/
  68. C***
  69. C write(6,*)' DBUT KCOT '
  70. NTO=NTB
  71. CALL LITABS(LTAB,KTAB,NTB,NTO,IRET)
  72. IF (IERR.NE.0) RETURN
  73. MTABD=KTAB(1)
  74.  
  75. CALL INITD(AAJ,81,0.D0)
  76. TYPE=' '
  77. CALL ACMO(MTABD,'CENTRE',TYPE,MELEMC)
  78. IF(TYPE.NE.'MAILLAGE')GO TO 90
  79.  
  80. IF(IDIM.EQ.2)NC=11
  81. IF(IDIM.EQ.3)NC=13
  82.  
  83. TYPE='CENTRE'
  84. CALL CRCHPT(TYPE,MELEMC,NC,MCHPOI)
  85. CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOM)
  86.  
  87. TYPE=' '
  88. CALL ACMO(MTABD,'MAILLAGE',TYPE,MELEME)
  89. IF(TYPE.NE.'MAILLAGE')GO TO 90
  90. SEGACT MELEME
  91.  
  92. IAXI=0
  93. IF(IFOMOD.EQ.0)IAXI=2
  94. NPGI=1
  95.  
  96. NBSOUS=LISOUS(/1)
  97. IF(NBSOUS.EQ.0)NBSOUS=1
  98.  
  99. K0=0
  100. DO 1 L=1,NBSOUS
  101. IPT1=MELEME
  102. IF(NBSOUS.NE.1)IPT1=LISOUS(L)
  103. SEGACT IPT1
  104. NP=IPT1.NUM(/1)
  105. NEL=IPT1.NUM(/2)
  106. NOM0=NOMS(IPT1.ITYPEL)//' '
  107. CALL OPTLI(IP,LISTS,NOM0,NLTS)
  108. IF(IP.EQ.0)THEN
  109. WRITE(6,*)' Il y a des types d''éléments pour lesquels on ne sait'
  110. &,'pas faire'
  111. GO TO 1
  112. ENDIF
  113. CALL KALPBG(NOM0,'FONFORM ',IZFFM)
  114. SEGACT IZFFM*MOD
  115. IZHR=KZHR(1)
  116. SEGACT IZHR*MOD
  117. NES=GR(/1)
  118. NPG=GR(/3)
  119.  
  120. DO 10 K=1,NEL
  121. KK=K0+K
  122. NPGR=0
  123. IF(IAXI.NE.0)NPGR=NPG
  124. C
  125. C REMPLISSAGE DE XYZ
  126. C ------------------
  127. C
  128. DO 12 I=1,NP
  129. J=IPT1.NUM(I,K)
  130. DO 12 N=1,IDIM
  131. XYZ(N,I)=XCOOR((J-1)*(IDIM+1)+N)
  132. 12 CONTINUE
  133.  
  134. IF(IP.EQ.6)THEN
  135. IN=0
  136. DO 13 I=1,NP,2
  137. J=IPT1.NUM(I,K)
  138. DO 13 N=1,IDIM
  139. IN=IN+1
  140. XQ(IN)=XCOOR((J-1)*(IDIM+1)+N)
  141. 13 CONTINUE
  142. ELSEIF(IP.GT.6)THEN
  143. IN=0
  144. DO 14 I=1,NP-1,2
  145. J=IPT1.NUM(I,K)
  146. DO 14 N=1,IDIM
  147. IN=IN+1
  148. XQ(IN)=XCOOR((J-1)*(IDIM+1)+N)
  149. 14 CONTINUE
  150. ENDIF
  151.  
  152. IF(IP.LE.5)CALL CALJAJ(GR,XYZ,NES,IDIM,NP,NPGI,AAJ)
  153. C
  154. CALL CALJBC(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,IDIM,NP,NPG,IAXI,AIRE)
  155.  
  156. IF(AIRE.LE.0)AIRE=ABS(AIRE)
  157.  
  158.  
  159. C CALCUL DES LONGUEURS DES COTES DE L'ELEMENT
  160. C UNIQUEMENT POUR LES SEG2 QUA4 ET CUB8
  161.  
  162. XML=0.D0
  163. DO 231 N=1,IDIM
  164. XML=XML+(XYZ(N,1)-XYZ(N,2))*(XYZ(N,1)-XYZ(N,2))
  165. 231 CONTINUE
  166. XML=SQRT(XML)
  167. C
  168. C
  169. IF(XML.EQ.0.D0)
  170. &WRITE(6,*)' ELEMENT DEGENERE ( AYANT UN COTE DE LONGUEUR NULLE) '
  171. C
  172. C
  173. IF(NOM0.EQ.'SEG2 ')THEN
  174. T(1)=XML
  175. CALL CALJQB(XYZ,T(5),IDIM,IDIM)
  176. GOTO 244
  177. ELSEIF(NOM0.EQ.'SEG3 ')THEN
  178. T(1)=XML
  179. CALL CALJQB(XQ,T(5),IDIM,IDIM)
  180. GOTO 244
  181. ENDIF
  182. C
  183. C
  184. XMH=0.D0
  185. DO 232 N=1,IDIM
  186. XMH=XMH+(XYZ(N,2)-XYZ(N,3))*(XYZ(N,2)-XYZ(N,3))
  187. 232 CONTINUE
  188. XMH=SQRT(XMH)
  189. C WRITE(6,*)'........XML XMH NP NES ',XML,XMH,NP,NES
  190.  
  191. C
  192. C
  193. IF(XMH.EQ.0.D0)
  194. &WRITE(6,*)' ELEMENT DEGENERE ( AYANT UN COTE DE LONGUEUR NULLE) '
  195. C
  196. C
  197.  
  198. IF(NOM0.EQ.'QUA4 '.OR.NOM0.EQ.'TRI3 ')THEN
  199. T(1)=XML
  200. T(2)=XMH
  201. T(3)=AAJ(1,1,1)/XML
  202. T(4)=AAJ(2,1,1)/XML
  203. CALL CALJQB(XYZ,T(5),IDIM,IDIM)
  204. GOTO 244
  205. ELSEIF(NOM0.EQ.'QUA9 '.OR.NOM0.EQ.'TRI7 ')THEN
  206. T(1)=XML
  207. T(2)=XMH
  208. T(3)=AAJ(1,1,1)/XML
  209. T(4)=AAJ(2,1,1)/XML
  210. CALL CALJQB(XQ,T(5),IDIM,IDIM)
  211. GOTO 244
  212. ENDIF
  213.  
  214. IF(NOM0.EQ.'CUB8 '.OR.NOM0.EQ.'PRI6 ')THEN
  215.  
  216. XME=0.D0
  217. IF(NOM0.EQ.'CUB8 ')THEN
  218. DO 242 N=1,IDIM
  219. XME=XME+(XYZ(N,1)-XYZ(N,5))*(XYZ(N,1)-XYZ(N,5))
  220. 242 CONTINUE
  221. ENDIF
  222.  
  223. IF(NOM0.EQ.'PRI6 ')THEN
  224. DO 243 N=1,IDIM
  225. XME=XME+(XYZ(N,1)-XYZ(N,4))*(XYZ(N,1)-XYZ(N,4))
  226. 243 CONTINUE
  227. ENDIF
  228.  
  229. XME=SQRT(XME)
  230. C WRITE(6,*)'........XML XMH XME NP NES ',XML,XMH,XME,NP,NES
  231. C
  232. IF(XME.EQ.0.D0)
  233. &WRITE(6,*)' ELEMENT DEGENERE ( AYANT UN COTE DE LONGUEUR NULLE) '
  234. C
  235. C
  236. CALL CALJQB(XYZ,T(5),IDIM,4)
  237. T(1)=XML
  238. T(2)=XMH
  239. T(3)=XME
  240. GO TO 244
  241. ENDIF
  242.  
  243. 244 CONTINUE
  244.  
  245. CALL RSETIV(VPOCHA,NC,KK,T,NC)
  246.  
  247. C write(6,*)' KK=',KK
  248. C write(6,1002)T
  249. 10 CONTINUE
  250. K0=K0+NEL
  251. SEGDES IPT1
  252. 1 CONTINUE
  253. SEGDES MELEME,MPOVAL,MCHPOI
  254. C
  255. CALL ECROBJ('CHPOINT ',MCHPOI)
  256.  
  257. C write(6,*)' FIN KCOT '
  258. RETURN
  259.  
  260. 90 CONTINUE
  261. WRITE(6,*)' Interruption anormale de KCOT'
  262. C Option %m1:8 incompatible avec les données
  263. CALL ERREUR(803)
  264. RETURN
  265. 1001 FORMAT(20(1X,I5))
  266. 1002 FORMAT(10(1X,1PE11.4))
  267. END
  268.  
  269.  
  270.  
  271.  
  272.  
  273.  
  274.  
  275.  
  276.  

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