Télécharger kcht.eso

Retour à la liste

Numérotation des lignes :

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

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