Télécharger komcha.eso

Retour à la liste

Numérotation des lignes :

  1. C KOMCHA SOURCE PV 17/06/16 14:33:47 9460
  2. SUBROUTINE KOMCHA(IPTR,IPMAIL,CONM,IPNOMC,MOTYPE,ICOND,INFOS,
  3. & NINFO,IPTVAL)
  4. C
  5. IMPLICIT INTEGER(I-N)
  6. IMPLICIT REAL*8(A-H,O-Z)
  7. C--------------------------------------------------------------------*
  8. C *
  9. C Recherche des valeurs des composantes dans les MELVAL d'un *
  10. C CHAMELEM. On distingue les composantes obligatoires des *
  11. C composantes facultatives. *
  12. C *
  13. C--------------------------------------------------------------------*
  14. C *
  15. C Entrées: *
  16. C *
  17. C IPTR pointeur sur le MCHAML *
  18. C IPMAIL sous zone élémentaire de l'objet MAILLAGE *
  19. C pointée par le MODELE *
  20. C CONM nom du constituant de la sous-zone *
  21. C IPNOMC pointeur sur les listes de composantes *
  22. C obligatoires et facultatives (ACTIF E/S) *
  23. C MOTYPE pointeur sur un segment definissant les types des *
  24. C composantes cherchees (ACTIF E/S) *
  25. C Si le segment est vide, on ne fait pas la *
  26. C verification sur les types *
  27. C ICOND lecture impérative ou non des composantes *
  28. C obligatoires ( 1 si oui, 0 sinon ) *
  29. C AM 8/12/93 ( on ajoute le cas icond = 2 qui est une lecture *
  30. C imperative mais sans test sur le nom de la *
  31. C composante si le MCHAML n'a qu'une composante *
  32. C et que l'on ne cherche qu'une composante) *
  33. C ( utilisé dans MATER et MANU ) *
  34. C INFOS les INFOS à comparer à INFCHE *
  35. C NINFO leur nombre *
  36. C *
  37. C SORTIES: *
  38. C *
  39. C IPTVAL pointeur pointant sur le tableau de pointeur *
  40. C associé a tous les MELVAL correspondant à la *
  41. C sous zone (ACTIF S) *
  42. C = 0 en cas d'ERREUR (et IERR est aussi non nul) *
  43. C *
  44. C--------------------------------------------------------------------*
  45. C *
  46. C Remarques *
  47. C *
  48. C on commence par ne tester l'identité des géométries que sur les *
  49. C pointeurs. Sans succès, on teste ensuite sur le contenu des *
  50. C maillages. Ainsi, dans le cas où des pointeurs conviennent, *
  51. C on s'arrête sans regarder si d'autres maillages conviendraient *
  52. C aussi, sans pour autant avoir le bon pointeur. *
  53. C *
  54. C on ne teste le constituant que s'il y a plusieurs sous-chamelem *
  55. C éligibles *
  56. C *
  57. C--------------------------------------------------------------------*
  58. C *
  59. C PM : 08/08/2006 *
  60. C si lecture facultative seulement et aucune composante lue *
  61. C alors renvoie un segment vide (NSR=0,NCOSOR=0) *
  62. C *
  63. C--------------------------------------------------------------------*
  64. -INC CCOPTIO
  65. C
  66. -INC SMCHAML
  67. C
  68. SEGMENT NOMID
  69. CHARACTER*8 LESOBL(NBROBL),LESFAC(NBRFAC)
  70. ENDSEGMENT
  71. C
  72. SEGMENT NOTYPE
  73. CHARACTER*16 TYPE(NBTYPE)
  74. ENDSEGMENT
  75. C
  76. SEGMENT MPTVAL
  77. INTEGER IPOS(NSR) ,NSOF(NSR)
  78. INTEGER IVAL(NCOSOR)
  79. CHARACTER*16 TYVAL(NCOSOR)
  80. ENDSEGMENT
  81. C
  82. LOGICAL LOG
  83. C
  84. CHARACTER*4 NOHA
  85. INTEGER*4 IHA
  86. EQUIVALENCE(NOHA,IHA)
  87. DATA NOHA/'NOHA'/
  88. CHARACTER*(NCONCH) CONM
  89. INTEGER INFOS(*)
  90. C
  91. IF (IIMPI.GT.0) write (IOIMP,*) 'komcha'
  92. C
  93. NOMID=IPNOMC
  94. SEGACT NOMID
  95. NBROBL=LESOBL(/2)
  96. NBRFAC=LESFAC(/2)
  97. C
  98. NOTYPE=MOTYPE
  99. SEGACT NOTYPE
  100. NBTYPE=TYPE(/2)
  101. C
  102. NSR = 10
  103. NCOSOR = NSR * ( NBROBL + NBRFAC )
  104. SEGINI MPTVAL
  105.  
  106. IPTVAL=MPTVAL
  107. C
  108. MCHELM=IPTR
  109. *** WRITE(IOIMP,*)'DANS KOMCHA, Avant SEGACT 1',MCHELM
  110. SEGACT,MCHELM
  111. N1 = IMACHE(/1)
  112. N3 = INFCHE(/2)
  113. NN3 = MIN(N3,NINFO)
  114. C
  115. C Recherche du ICHAML correspondant à la zone élémentaire
  116. C pointée par le modèle
  117. C
  118. C Nombre de sous-zones du chamelem éligibles
  119. INS=0
  120. LOG = .FALSE.
  121. DO I=1,N1
  122. IF (IPMAIL.EQ.IMACHE(I)) INS=INS+1
  123. IF (CONCHE(I).NE.' ') LOG = .TRUE.
  124. ENDDO
  125. C
  126. C AM 16/03/07
  127. C EN CAS DE CONSTITUANTS TOUS ' ', ON APELLE
  128. C TESTMA AVEC LOG = .FALSE. AU LIEU DE .TRUE.
  129. C
  130. NS = 0
  131. C
  132. DO 1 I=1,N1
  133. C ON IDENTIFIE LE ICHAML
  134. C
  135. C on ne teste l'identité des géométries que sur les pointeurs
  136. C on ne teste le constituant que s'il y a plusieurs sous-chamelem éligibles
  137. C write (6,*) ' komcha i conm conche',i,conm,conche(i)
  138. IF ( IPMAIL.NE.IMACHE(I) .OR.
  139. & (INS.NE.1.AND.CONM.NE.CONCHE(I)) ) GO TO 1
  140. C
  141. C ON VERIFIE LA COMPATIBILITE DES INFOS
  142. C
  143. IF (NN3.EQ.0) THEN
  144. NS=NS+1
  145. C write (6,*) ' komcha-1 ns i ',ns,i
  146. ELSE
  147. DO J=1,NN3
  148. C test numéro d'harmonique
  149. IF (INFOS(J).NE.INFCHE(I,J).AND.(IHA.NE.INFCHE(I,J))) GOTO 1
  150. ENDDO
  151. NS=NS+1
  152. C write (6,*) ' komcha-2 ns i j ',ns,i,j
  153. ENDIF
  154. IF (NS.GT.NSR) THEN
  155. NSR = NS+100
  156. SEGADJ MPTVAL
  157. ENDIF
  158. IPOS(NS) = I
  159. 1 CONTINUE
  160. C
  161. IF (NS.EQ.0) THEN
  162. C Aucun pointeur ne correspond
  163. C On teste alors les maillages eux-mêmes et leurs points
  164. CALL TESTMA(IPTR,IPMAIL,LOG,CONM,IPTRET,IMODI)
  165.  
  166. MCHELM=IPTR
  167. SEGDES,MCHELM
  168.  
  169. IF (IERR.NE.0) GOTO 9999
  170. IF (IPTRET.EQ.0) THEN
  171. C On n'a pas trouvé, dans un CHAMELEM, de zone géométrique ou
  172. C de constituant correspondant à l'objet MODELE
  173. CALL ERREUR(472)
  174. GOTO 9999
  175. ENDIF
  176.  
  177. C on a trouvé un sous-maillage
  178. MCHELM=IPTRET
  179. *** WRITE(IOIMP,*)'DANS KOMCHA, Avant SEGACT 2',MCHELM
  180. SEGACT,MCHELM
  181. N1 = IMACHE(/1)
  182. N3 = INFCHE(/2)
  183. NN3 = MIN(N3,NINFO)
  184. C
  185. C ON VERIFIE A NOUVEAU LA COMPATIBILITE DES INFOS
  186. C
  187. DO 11 I=1,N1
  188. IF (NN3.EQ.0) THEN
  189. NS=NS+1
  190. C write (6,*) ' komcha-3 ns i ',ns,i
  191. ELSE
  192. DO J=1,NN3
  193. C test numéro d'harmonique
  194. IF (INFOS(J).NE.INFCHE(I,J).AND.(IHA.NE.INFCHE(I,J))) GOTO 11
  195. ENDDO
  196. NS=NS+1
  197. C write (6,*) ' komcha-4 ns i j ',ns,i,j
  198. ENDIF
  199. IF (NS.GT.NSR) THEN
  200. NSR = NS+100
  201. SEGADJ MPTVAL
  202. ENDIF
  203. IPOS(NS) = I
  204. 11 CONTINUE
  205. ENDIF
  206. C
  207. C TEST SUR LA NULLITE DE NS AM
  208. IF (NS.EQ.0) THEN
  209. C la sous zone de maillage %i1 et de constituant %m1:16 a des
  210. C informations relatives au champ ( infche) erronnées
  211. MOTERR = CONM
  212. INTERR(1) = IPMAIL
  213. CALL ERREUR(877)
  214. GOTO 9999
  215. ENDIF
  216.  
  217. C-- Identification sur les autres critères
  218. C
  219. NSR = NS
  220. NCOSOR = NS * ( NBROBL + NBRFAC )
  221. SEGADJ,MPTVAL
  222. C
  223. LECAPA=0
  224. IF (ICOND.EQ.2 .AND. NS.EQ.1 .AND. NBROBL.EQ.1 .AND. NBRFAC.EQ.0)
  225. & LECAPA=1
  226. C
  227. DO JJ=1,NS
  228. ITAB=1
  229. C
  230. C Activation du ICHAML
  231. C
  232. MCHAML=ICHAML(IPOS(JJ))
  233. SEGACT,MCHAML
  234. IF(NOMCHE(/2).NE.1) LECAPA=0
  235. C
  236. C Composantes obligatoires
  237. NSOF(JJ)=0
  238. DO IC1=1,nbrobl
  239. CALL PLACE(NOMCHE,NOMCHE(/2),IPLAC,LESOBL(IC1-ITAB+1))
  240. IF (IPLAC.EQ.0.AND.LECAPA.EQ.1) IPLAC=1
  241. IF (IPLAC.NE.0) THEN
  242. C une seule zone autorisee PV
  243. if (ival(ic1).ne.0) then
  244. interr(1)=ipmail
  245. moterr=conm
  246. call erreur(769)
  247. GOTO 9999
  248. endif
  249. NSOF(JJ)=NSOF(JJ)+1
  250. IVAL(IC1)=IELVAL(IPLAC)
  251. MELVAL=IELVAL(IPLAC)
  252. SEGACT,MELVAL
  253. C Vérification du type si donné
  254. IF (NBTYPE.EQ.0) GO TO 7
  255. ICMN=MIN(IC1,NBTYPE)
  256. IF (TYPE(ICMN).NE.TYPCHE(IPLAC)
  257. $ .AND.TYPE(ICMN).NE.' ') THEN
  258. MOTERR(1:16) = TYPCHE(IPLAC)
  259. MOTERR(17:24) = LESOBL(IC1-ITAB+1)
  260. MOTERR(25:40) = TITCHE
  261. CALL ERREUR(552)
  262. SEGDES,MCHAML
  263. SEGDES,MCHELM
  264. GOTO 9999
  265. ENDIF
  266. 7 TYVAL(IC1)=TYPCHE(IPLAC)
  267. C SEGDES,MELVAL
  268. ENDIF
  269. ENDDO
  270. C
  271. C Composantes facultatives
  272. NBOFAC=0
  273. ITAB=ITAB+NBROBL
  274. DO IC2=ITAB,NBRFAC+ITAB-1
  275. IVAL(IC2)=0
  276. CALL PLACE(NOMCHE,NOMCHE(/2),IPLAC,LESFAC(IC2-ITAB+1))
  277. IF (IPLAC.NE.0) THEN
  278. if (ival(ic2).ne.0) then
  279. interr(1)=ipmail
  280. moterr=conm
  281. call erreur(769)
  282. GOTO 9999
  283. ENDIF
  284. NSOF(JJ)=NSOF(JJ)+1
  285. IVAL(IC2)=IELVAL(IPLAC)
  286. MELVAL=IELVAL(IPLAC)
  287. SEGACT,MELVAL
  288. C Vérification du type si donné
  289. IF(NBTYPE.EQ.0) GO TO 8
  290. ICMN=MIN(IC2,NBTYPE)
  291. IF (TYPE(ICMN).NE.TYPCHE(IPLAC)
  292. $ .AND.TYPE(ICMN).NE.' ') THEN
  293. MOTERR(1:16)=TYPCHE(IPLAC)
  294. MOTERR(17:24)=LESFAC(IC2-ITAB+1)
  295. MOTERR(25:40)=TITCHE
  296. CALL ERREUR(552)
  297. SEGDES,MCHAML
  298. SEGDES,MCHELM
  299. GOTO 9999
  300. ENDIF
  301. 8 TYVAL(IC2)=TYPCHE(IPLAC)
  302. NBOFAC=NBOFAC+1
  303. C* SEGDES,MELVAL
  304. ENDIF
  305. ENDDO
  306.  
  307. CPM si lecture facultative seulement et aucune composante lue
  308. CPM alors renvoie un segment vide (NS=0,NCOSOU=0)
  309. IF (NBROBL.EQ.0 .AND. NBRFAC.GT.0) THEN
  310. IF (NS.EQ.0 .AND. NBOFAC.EQ.0) THEN
  311. NSR = 0
  312. NCOSOR = 0
  313. SEGADJ, MPTVAL
  314. ENDIF
  315. ENDIF
  316.  
  317. CPM ITAB n'est plus utilisé par la suite.
  318. CPM ITAB=ITAB+NBRFAC
  319. C
  320. C* SEGDES,MCHAML
  321. ENDDO
  322. C verification que les composantes obligatoires sont toutes presentes
  323. DO IC1=1,NBROBL
  324. if (ival(ic1).eq.0) then
  325. IF (ICOND.EQ.1.OR.ICOND.EQ.2) THEN
  326. MOTERR(1:8)=LESOBL(IC1)
  327. MOTERR(9:16)=TITCHE
  328. CALL ERREUR(77)
  329. ELSE
  330. C Données incompatibles
  331. CALL ERREUR(21)
  332. ENDIF
  333. GOTO 9999
  334. ENDIF
  335. ENDDO
  336. C
  337. 9999 CONTINUE
  338. C* SEGDES,MCHELM
  339. C* SEGDES,NOMID,NOTYPE
  340. IF (IERR.NE.0) THEN
  341. CALL DTMVAL(IPTVAL,1)
  342. IPTVAL = 0
  343. ENDIF
  344. C
  345. RETURN
  346. END
  347.  
  348.  
  349.  
  350.  
  351.  
  352.  
  353.  

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