Télécharger kcht.eso

Retour à la liste

Numérotation des lignes :

  1. C KCHT SOURCE CB215821 16/04/13 21:15:01 8904
  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. SEGDES MELEME
  148. SEGINI MCHPOI,MSOUPO,MPOVAL
  149. C write(6,*)' KCHT on initialise MCHPOI n,nc=',n,nc
  150.  
  151. MTYPOI=TYPG
  152. MOCHDE=TITREE
  153. JATTRI(1)=2
  154. IPCHP(1)=MSOUPO
  155. IFOPOI=IFOMOD
  156. IF(NC.EQ.1)THEN
  157. C write(6,*)' On attribue le nom de composante :',ncos,' :'
  158. NOCOMP(1)=NCOS
  159. ELSE
  160. DO 127 I=1,NC
  161. C write(6,*)' On attribue le nom de composante :',ncov(i),' :'
  162. NOCOMP(I)=NCOV(I)
  163. 127 CONTINUE
  164. ENDIF
  165. IGEOC=MELEME
  166. IPOVAL=MPOVAL
  167.  
  168. IF(MTYP.EQ.'FLOTTANT'.OR.MTYP.EQ.'ENTIER ')THEN
  169. C On initialise le CHPOINT a une constante si c'est un SCAL
  170. IF(NC.NE.1)THEN
  171. WRITE(6,*)' CHPOINT SCAL Initialisation incompatible '
  172. CALL ERREUR(156)
  173. C Le chpoint donné est vide, ou bien son contenu est incompatible avec les n
  174. C de composante imposés par le listmots et le mot-clé (donné ou sous-entendu
  175. RETURN
  176. ENDIF
  177.  
  178. CALL LIRREE(XVAL(1),1,IRET)
  179. CALL INITD(VPOCHA,N,XVAL(1))
  180.  
  181. ELSEIF(MTYP.EQ.'POINT ')THEN
  182. IF(NC.EQ.1)THEN
  183. WRITE(6,*)' CHPOINT VECT Initialisation incompatible '
  184. CALL ERREUR(156)
  185. C Le chpoint donné est vide, ou bien son contenu est incompatible avec les n
  186. C de composante imposés par le listmots et le mot-clé (donné ou sous-entendu
  187. RETURN
  188. ENDIF
  189. CALL LIROBJ('POINT ',IP,1,IRET)
  190. XVAL(1)=XCOOR((IP-1)*(IDIM+1) +1)
  191. XVAL(2)=XCOOR((IP-1)*(IDIM+1) +2)
  192. IF(NC.EQ.3)XVAL(3)=XCOOR((IP-1)*(IDIM+1) +3)
  193. C On construit le CHPOINT résultat si celui-ci ne l'a pas déjà été ...
  194. CALL INITD(VPOCHA,N,XVAL(1))
  195. CALL INITD(VPOCHA(1,2),N,XVAL(2))
  196. IF(NC.EQ.3)CALL INITD(VPOCHA(1,3),N,XVAL(3))
  197. IF(NC.EQ.4.OR.NC.EQ.9)WRITE(6,*)' Cas non encore implemente'
  198.  
  199. ELSEIF(MTYP.NE.'CHPOINT')THEN
  200. WRITE(6,*)' Type d objet incorrect pour l initialisation'
  201. C Indice %m1:8 : Objet de type %m9:16 incorrect
  202. MOTERR(1:8)=' '
  203. MOTERR(9:16)=MTYP
  204. CALL ERREUR(787)
  205. RETURN
  206. ENDIF
  207.  
  208.  
  209. C write(6,*)' On cherche les champoints à charger ... '
  210. CALL KRIPAD(MELEME,MLENTI)
  211. 10 CONTINUE
  212. CALL LIROBJ('CHPOINT',MCHPO1,0,IRET)
  213. IF(IRET.EQ.0)GO TO 11
  214.  
  215. SEGACT MCHPO1
  216. NSOUP1=MCHPO1.IPCHP(/1)
  217.  
  218. IKCOMP=0
  219. DO 1 L=1,NSOUP1
  220. MSOUP1=MCHPO1.IPCHP(1)
  221. SEGACT MSOUP1
  222. NC1=MSOUP1.NOCOMP(/2)
  223. DO 2 M=1,NC1
  224. DO 3 K=1,NC
  225. C write(6,*)' ncomp1=',MSOUP1.NOCOMP(M),' ncomp=',NOCOMP(K)
  226.  
  227. IF(MSOUP1.NOCOMP(M).EQ.NOCOMP(K))THEN
  228. IKCOMP=IKCOMP+1
  229. MELEME=MSOUP1.IGEOC
  230. MPOVA1=MSOUP1.IPOVAL
  231. SEGACT MELEME,MPOVA1
  232. NPT=NUM(/2)
  233. IKVAL=0
  234. DO 4 I=1,NPT
  235. I1=LECT(NUM(1,I))
  236. IF(I1.EQ.0)GO TO 4
  237. IKVAL=IKVAL+1
  238. VPOCHA(I1,K)=MPOVA1.VPOCHA(I,M)
  239. 4 CONTINUE
  240. SEGDES MELEME,MPOVA1
  241. IF(IKVAL.EQ.0)THEN
  242. write(6,*)' Opérateur KCHT : aucun point pour la composante ',
  243. &NOCOMP(M)
  244. C Le chpoint donné est vide, ou bien son contenu est incompatible avec les noms
  245. Cde composante imposés par le listmots et le mot-clé (donné ou sous-entendu)
  246. CALL ERREUR(156)
  247. RETURN
  248. ENDIF
  249. IF(KVERIF.NE.0)THEN
  250. write(6,*)' Opérateur KCHT : la composante ',NOCOMP(M),
  251. &' a été initialisée'
  252. ENDIF
  253.  
  254. ENDIF
  255.  
  256. 3 CONTINUE
  257. 2 CONTINUE
  258. SEGDES MSOUP1
  259. 1 CONTINUE
  260. IF(IKCOMP.EQ.0)THEN
  261. write(6,*)' Opérateur KCHT : '
  262. write(6,*)' Aucune composante n''a été initialisée'
  263. write(6,*)' Liste des composantes : '
  264. DO 21 L=1,NSOUP1
  265. MSOUP1=MCHPO1.IPCHP(1)
  266. SEGACT,MSOUP1
  267. NC1=MSOUP1.NOCOMP(/2)
  268. DO 22 M=1,NC1
  269. DO 22 K=1,NC
  270. write(6,*)' ncomp1=',MSOUP1.NOCOMP(M),' ncomp=',NOCOMP(K)
  271. 22 CONTINUE
  272. SEGDES,MSOUP1
  273. 21 CONTINUE
  274. C La composante %m1:4 n'existe pas pour le champ %m5:8
  275. MOTERR(1:4)=' '
  276. MOTERR(5:8)=' '
  277. CALL ERREUR(77)
  278.  
  279. RETURN
  280. ENDIF
  281. SEGDES MCHPO1
  282.  
  283. GO TO 10
  284.  
  285. 11 CONTINUE
  286.  
  287. SEGDES MPOVAL,MSOUPO,MCHPOI
  288. IF(MLENTI.NE.0)SEGSUP MLENTI
  289. CALL ECROBJ('CHPOINT ',MCHPOI)
  290. RETURN
  291.  
  292. 90 CONTINUE
  293. WRITE(6,*)' Arret anormal dans KCHT '
  294. C Tache impossible. Probablement données erronées
  295. CALL ERREUR(26)
  296.  
  297.  
  298. RETURN
  299. END
  300.  
  301.  
  302.  
  303.  
  304.  
  305.  
  306.  
  307.  
  308.  
  309.  
  310.  
  311.  
  312.  

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