Télécharger kcht.eso

Retour à la liste

Numérotation des lignes :

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

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