Télécharger kcht.eso

Retour à la liste

Numérotation des lignes :

  1. C KCHT SOURCE CB215821 19/08/20 21:18:46 10287
  2. SUBROUTINE KCHT
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. C*************************************************************************
  6. C Operateur KCHT
  7. C
  8. C OBJET : Cree un CHAMPOINT TRIO c'est a dire sous-type
  9. C SOMMET CENTRE ou FACE
  10. C
  11. C SYNTAXE : CH1 = KCHT tabdom TYPC TYPG <VERIF> <COMP nc>
  12. C <val1 > <CHP2> ;
  13. C
  14. C tabdom table domaine
  15. C
  16. C TYPC : SCAL TYPG : SOMMET
  17. C VECT CENTRE
  18. C FACE
  19. C nc nom donne a ou aux composantes
  20. C
  21. C
  22. C
  23. C
  24. C
  25. C*************************************************************************
  26. -INC CCOPTIO
  27. -INC SMCOORD
  28. -INC SMCHPOI
  29. -INC SMELEME
  30. -INC SMLENTI
  31. -INC SMLMOTS
  32.  
  33. CHARACTER*8 TYPC,TYPG,LTYPC(3),LTYPG(8),MTYP,TYPE,TYPS
  34. CHARACTER*4 NCOS,NCOV(3),NCOSI,NCOVI(3)
  35.  
  36. REAL*8 XVAL(3)
  37.  
  38. DATA LTYPC/'SCAL ','VECT ','MATR '/
  39. DATA LTYPG/'SOMMET ','CENTRE ','FACE ','CENTREP0','CENTREP1',
  40. &'MSOMMET ','COMP ','VERIF '/
  41. DATA NCOSI/'SCAL'/,NCOVI/'UX ','UY ','UZ '/
  42. C***
  43.  
  44. MLENTI=0
  45. NCOS=NCOSI
  46. NCOV(1)=NCOVI(1)
  47. NCOV(2)=NCOVI(2)
  48. NCOV(3)=NCOVI(3)
  49.  
  50. XVAL(1) = 0.D0
  51. XVAL(2) = 0.D0
  52. XVAL(3) = 0.D0
  53. MCHPOI = 0
  54.  
  55. CALL LITDMD(MMODEL,MTABD,IRET)
  56. IF(IRET.EQ.0)RETURN
  57. IF(MTABD.EQ.0)CALL LEKMOD(MMODEL,MTABD,INEFMD)
  58. C INEFMD=1 LINE =2 MACRO =3 QUADRATIQUE =4 LINB
  59.  
  60.  
  61. C WRITE(*,*)' on cherche les MOT des sous-type du CHPOINT résultat'
  62. C
  63. C SCAL SOMMET
  64. C VECT FACE
  65. C CENTRE
  66.  
  67. CALL LIRMOT(LTYPC,3,IPC,1)
  68. IF(IPC.EQ.0)RETURN
  69. CALL LIRMOT(LTYPG,6,IPG,1)
  70. IF(IPG.EQ.0)RETURN
  71.  
  72. IF(IPC.EQ.1)THEN
  73. NC=1
  74. ELSEIF(IPC.EQ.2)THEN
  75. NC=IDIM
  76. ELSEIF(IPC.EQ.3)THEN
  77. NC=IDIM*IDIM
  78. ENDIF
  79.  
  80. CALL QUETYP(MTYP,0,IRET)
  81. IF(IRET.EQ.0)GO TO 90
  82. IF(MTYP.EQ.'MOT')THEN
  83. CALL LIRMOT(LTYPG(7),2,IPC,1)
  84. IF(IPC.EQ.0)THEN
  85. C Il manque le mot-clé %m1:4
  86. MOTERR(1:4)='COMP'
  87. CALL ERREUR(396)
  88. MOTERR(1:4)='VERI'
  89. CALL ERREUR(396)
  90.  
  91. RETURN
  92. ENDIF
  93.  
  94. IF(IPC.EQ.1)THEN
  95. IF(NC.EQ.1)THEN
  96. CALL LIRCHA(NCOS,1,IRET)
  97. IF(IRET.EQ.0)RETURN
  98. ELSE
  99. CALL QUETYP(MTYP,0,IRET)
  100. C write(6,*)' MTYP,nc=',MTYP,nc
  101. IF(IRET.EQ.0)RETURN
  102. IF(MTYP.EQ.'LISTMOTS')THEN
  103. CALL LIROBJ('LISTMOTS',MLMOTS,1,IRET)
  104. IF(IRET.EQ.0)RETURN
  105. SEGACT MLMOTS
  106. JGM=MOTS(/2)
  107. DO 128 I=1,NC
  108. C? CALL LIRCHA(NCOV(I),1,IRET)
  109. C? IF(IRET.EQ.0)RETURN
  110. NCOV(I)=MOTS(I)
  111. 128 CONTINUE
  112.  
  113. ELSEIF(MTYP.EQ.'MOT')THEN
  114. DO 129 I=1,NC
  115. CALL LIRCHA(NCOV(I),1,IRET)
  116. IF(IRET.EQ.0)RETURN
  117. 129 CONTINUE
  118. ELSE
  119. RETURN
  120. ENDIF
  121. ENDIF
  122. ELSEIF(IPC.EQ.2)THEN
  123. ENDIF
  124.  
  125. CALL QUETYP(MTYP,0,IRET)
  126. IF(IRET.EQ.0)GO TO 90
  127.  
  128. ENDIF
  129.  
  130. IF(IPG.GE.4.AND.IPG.NE.6)THEN
  131. IF(INEFMD.NE.2.AND.INEFMD.NE.3.AND.INEFMD.NE.4)THEN
  132. C Option %m1:8 incompatible avec les données
  133. MOTERR( 1: 8) = LTYPG(IPG)
  134. CALL ERREUR(803)
  135. RETURN
  136. ENDIF
  137. ENDIF
  138.  
  139. TYPG=LTYPG(IPG)
  140. CALL LEKTAB(MTABD,TYPG,MELEME)
  141.  
  142.  
  143. NAT=2
  144. NSOUPO=1
  145. SEGACT MELEME
  146. N=NUM(/2)
  147. SEGINI MCHPOI,MSOUPO,MPOVAL
  148. C write(6,*)' KCHT on initialise MCHPOI n,nc=',n,nc
  149.  
  150. MTYPOI=TYPG
  151. MOCHDE=TITREE
  152. JATTRI(1)=2
  153. IPCHP(1)=MSOUPO
  154. IFOPOI=IFOMOD
  155. IF(NC.EQ.1)THEN
  156. C write(6,*)' On attribue le nom de composante :',ncos,' :'
  157. NOCOMP(1)=NCOS
  158. ELSE
  159. DO 127 I=1,NC
  160. C write(6,*)' On attribue le nom de composante :',ncov(i),' :'
  161. NOCOMP(I)=NCOV(I)
  162. 127 CONTINUE
  163. ENDIF
  164. IGEOC=MELEME
  165. IPOVAL=MPOVAL
  166.  
  167. IF(MTYP.EQ.'FLOTTANT'.OR.MTYP.EQ.'ENTIER ')THEN
  168. C On initialise le CHPOINT a une constante si c'est un SCAL
  169. IF(NC.NE.1)THEN
  170. WRITE(6,*)' CHPOINT SCAL Initialisation incompatible '
  171. CALL ERREUR(156)
  172. C Le chpoint donné est vide, ou bien son contenu est incompatible avec les n
  173. C de composante imposés par le listmots et le mot-clé (donné ou sous-entendu
  174. RETURN
  175. ENDIF
  176.  
  177. CALL LIRREE(XVAL(1),1,IRET)
  178. CALL INITD(VPOCHA,N,XVAL(1))
  179.  
  180. ELSEIF(MTYP.EQ.'POINT ')THEN
  181. IF(NC.EQ.1)THEN
  182. WRITE(6,*)' CHPOINT VECT Initialisation incompatible '
  183. CALL ERREUR(156)
  184. C Le chpoint donné est vide, ou bien son contenu est incompatible avec les n
  185. C de composante imposés par le listmots et le mot-clé (donné ou sous-entendu
  186. RETURN
  187. ENDIF
  188. CALL LIROBJ('POINT ',IP,1,IRET)
  189. XVAL(1)=XCOOR((IP-1)*(IDIM+1) +1)
  190. XVAL(2)=XCOOR((IP-1)*(IDIM+1) +2)
  191. IF(NC.EQ.3)XVAL(3)=XCOOR((IP-1)*(IDIM+1) +3)
  192. C On construit le CHPOINT résultat si celui-ci ne l'a pas déjà été ...
  193. CALL INITD(VPOCHA,N,XVAL(1))
  194. CALL INITD(VPOCHA(1,2),N,XVAL(2))
  195. IF(NC.EQ.3)CALL INITD(VPOCHA(1,3),N,XVAL(3))
  196. IF(NC.EQ.4.OR.NC.EQ.9)WRITE(6,*)' Cas non encore implemente'
  197.  
  198. ELSEIF(MTYP.NE.'CHPOINT')THEN
  199. WRITE(6,*)' Type d objet incorrect pour l initialisation'
  200. C Indice %m1:8 : Objet de type %m9:16 incorrect
  201. MOTERR(1:8)=' '
  202. MOTERR(9:16)=MTYP
  203. CALL ERREUR(787)
  204. RETURN
  205. ENDIF
  206.  
  207.  
  208. C write(6,*)' On cherche les champoints à charger ... '
  209. CALL KRIPAD(MELEME,MLENTI)
  210. 10 CONTINUE
  211. CALL LIROBJ('CHPOINT ',MCHPO1,0,IRET)
  212. IF(IRET.EQ.0)GO TO 11
  213. CALL ACTOBJ('CHPOINT ',MCHPO1,1)
  214.  
  215. NSOUP1=MCHPO1.IPCHP(/1)
  216.  
  217. IKCOMP=0
  218. DO 1 L=1,NSOUP1
  219. MSOUP1=MCHPO1.IPCHP(1)
  220. NC1=MSOUP1.NOCOMP(/2)
  221. DO 2 M=1,NC1
  222. DO 3 K=1,NC
  223. C write(6,*)' ncomp1=',MSOUP1.NOCOMP(M),' ncomp=',NOCOMP(K)
  224.  
  225. IF(MSOUP1.NOCOMP(M).EQ.NOCOMP(K))THEN
  226. IKCOMP=IKCOMP+1
  227. MELEME=MSOUP1.IGEOC
  228. MPOVA1=MSOUP1.IPOVAL
  229. NPT=NUM(/2)
  230. IKVAL=0
  231. DO 4 I=1,NPT
  232. I1=LECT(NUM(1,I))
  233. IF(I1.EQ.0)GO TO 4
  234. IKVAL=IKVAL+1
  235. VPOCHA(I1,K)=MPOVA1.VPOCHA(I,M)
  236. 4 CONTINUE
  237. IF(IKVAL.EQ.0)THEN
  238. write(6,*)' Opérateur KCHT : aucun point pour la composante ',
  239. &NOCOMP(M)
  240. C Le chpoint donné est vide, ou bien son contenu est incompatible avec les noms
  241. Cde composante imposés par le listmots et le mot-clé (donné ou sous-entendu)
  242. CALL ERREUR(156)
  243. RETURN
  244. ENDIF
  245. IF(KVERIF.NE.0)THEN
  246. write(6,*)' Opérateur KCHT : la composante ',NOCOMP(M),
  247. &' a été initialisée'
  248. ENDIF
  249.  
  250. ENDIF
  251.  
  252. 3 CONTINUE
  253. 2 CONTINUE
  254. 1 CONTINUE
  255. IF(IKCOMP.EQ.0)THEN
  256. write(6,*)' Opérateur KCHT : '
  257. write(6,*)' Aucune composante n''a été initialisée'
  258. write(6,*)' Liste des composantes : '
  259. DO 21 L=1,NSOUP1
  260. MSOUP1=MCHPO1.IPCHP(1)
  261. NC1=MSOUP1.NOCOMP(/2)
  262. DO 22 M=1,NC1
  263. DO 22 K=1,NC
  264. write(6,*)' ncomp1=',MSOUP1.NOCOMP(M),' ncomp=',NOCOMP(K)
  265. 22 CONTINUE
  266. 21 CONTINUE
  267. C La composante %m1:4 n'existe pas pour le champ %m5:8
  268. MOTERR(1:4)=' '
  269. MOTERR(5:8)=' '
  270. CALL ERREUR(77)
  271.  
  272. RETURN
  273. ENDIF
  274.  
  275. GO TO 10
  276.  
  277. 11 CONTINUE
  278.  
  279. IF(MLENTI.NE.0)SEGSUP MLENTI
  280. CALL ACTOBJ('CHPOINT ',MCHPOI,1)
  281. CALL ECROBJ('CHPOINT ',MCHPOI)
  282. RETURN
  283.  
  284. 90 CONTINUE
  285. WRITE(6,*)' Arret anormal dans KCHT '
  286. C Tache impossible. Probablement données erronées
  287. CALL ERREUR(26)
  288.  
  289. END
  290.  
  291.  
  292.  

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