Télécharger komcha.eso

Retour à la liste

Numérotation des lignes :

komcha
  1. C KOMCHA SOURCE CB215821 20/11/25 13:31:47 10792
  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.  
  65. -INC PPARAM
  66. -INC CCOPTIO
  67. C
  68. -INC SMCHAML
  69. C
  70. SEGMENT NOMID
  71. CHARACTER*8 LESOBL(NBROBL),LESFAC(NBRFAC)
  72. ENDSEGMENT
  73. C
  74. SEGMENT NOTYPE
  75. CHARACTER*16 TYPE(NBTYPE)
  76. ENDSEGMENT
  77. C
  78. SEGMENT MPTVAL
  79. INTEGER IPOS(NSR) ,NSOF(NSR), IVAL(NCOSOR)
  80. CHARACTER*16 TYVAL(NCOSOR)
  81. ENDSEGMENT
  82. C
  83. LOGICAL LOG
  84. C
  85. CHARACTER*4 NOHA
  86. INTEGER*4 IHA
  87. EQUIVALENCE(NOHA,IHA)
  88. DATA NOHA/'NOHA'/
  89. CHARACTER*(NCONCH) CONM
  90. INTEGER INFOS(*)
  91. C
  92. IF (IIMPI.GT.0) write (IOIMP,*) 'komcha'
  93. C
  94. NOMID=IPNOMC
  95. NBROBL=LESOBL(/2)
  96. NBRFAC=LESFAC(/2)
  97. C
  98. NOTYPE=MOTYPE
  99. NBTYPE=TYPE(/2)
  100. C
  101. MCHELM=IPTR
  102.  
  103. N1 = IMACHE(/1)
  104. N3 = INFCHE(/2)
  105. NN3 = MIN(N3,NINFO)
  106.  
  107. NSR = N1
  108. ** on ne se sert pas de ncosor avant le segadj final
  109. ** NCOSOR = NSR * ( NBROBL + NBRFAC )
  110. NCOSOR = 0
  111. SEGINI MPTVAL
  112. IPTVAL=MPTVAL
  113. C
  114. C Recherche du ICHAML correspondant à la zone élémentaire
  115. C pointée par le modèle
  116. C
  117. C Nombre de sous-zones du chamelem éligibles
  118. INS=0
  119. LOG = .FALSE.
  120. DO I=1,N1
  121. IF (IPMAIL.EQ.IMACHE(I)) INS=INS+1
  122. IF (CONCHE(I).NE.' ') LOG = .TRUE.
  123. ENDDO
  124. C
  125. C AM 16/03/07
  126. C EN CAS DE CONSTITUANTS TOUS ' ', ON APELLE
  127. C TESTMA AVEC LOG = .FALSE. AU LIEU DE .TRUE.
  128. C
  129. NS = 0
  130. C
  131. DO 1 I=1,N1
  132. C ON IDENTIFIE LE ICHAML
  133. C
  134. C on ne teste l'identité des géométries que sur les pointeurs
  135. C on ne teste le constituant que s'il y a plusieurs sous-chamelem éligibles
  136. C write (6,*) ' komcha i conm conche',i,conm,conche(i)
  137. IF ( IPMAIL.NE.IMACHE(I) .OR.
  138. & (INS.NE.1.AND.CONM.NE.CONCHE(I)) ) GOTO 1
  139. C
  140. C ON VERIFIE LA COMPATIBILITE DES INFOS
  141. C
  142. DO J=1,NN3
  143. C test numéro d'harmonique
  144. IF(INFOS(J).NE.INFCHE(I,J).AND.(IHA.NE.INFCHE(I,J))) GOTO 1
  145. ENDDO
  146. NS=NS+1
  147. IF (NS.GT.NSR) THEN
  148. ** write(6,*) ' extension 1 ',ns,nsr
  149. NSR = NS*2
  150. SEGADJ MPTVAL
  151. ENDIF
  152. IPOS(NS) = I
  153. 1 CONTINUE
  154. C
  155. IF (NS.EQ.0) THEN
  156. C Aucun pointeur ne correspond
  157. C On teste alors les maillages eux-mêmes et leurs points
  158. CALL TESTMA(IPTR,IPMAIL,LOG,CONM,IPTRET,IMODI)
  159.  
  160. MCHELM=IPTR
  161.  
  162. IF (IERR.NE.0) GOTO 9999
  163. IF (IPTRET.EQ.0) THEN
  164. C On n'a pas trouvé, dans un CHAMELEM, de zone géométrique ou
  165. C de constituant correspondant à l'objet MODELE
  166. CALL ERREUR(472)
  167. GOTO 9999
  168. ENDIF
  169.  
  170. C on a trouvé un sous-maillage
  171. MCHELM=IPTRET
  172. N1 = IMACHE(/1)
  173. N3 = INFCHE(/2)
  174. NN3 = MIN(N3,NINFO)
  175. C
  176. C ON VERIFIE A NOUVEAU LA COMPATIBILITE DES INFOS
  177. C
  178. DO 11 I=1,N1
  179. IF (NN3.EQ.0) THEN
  180. NS=NS+1
  181. C write (6,*) ' komcha-3 ns i ',ns,i
  182. ELSE
  183. DO J=1,NN3
  184. C test numéro d'harmonique
  185. IF (INFOS(J).NE.INFCHE(I,J).AND.(IHA.NE.INFCHE(I,J))) GOTO 11
  186. ENDDO
  187. NS=NS+1
  188. C write (6,*) ' komcha-4 ns i j ',ns,i,j
  189. ENDIF
  190. IF (NS.GT.NSR) THEN
  191. NSR = NS*2
  192. ** write(6,*) ' extension 2 ',ns,nsr
  193. SEGADJ MPTVAL
  194. ENDIF
  195. IPOS(NS) = I
  196. 11 CONTINUE
  197. ENDIF
  198. C
  199. C TEST SUR LA NULLITE DE NS AM
  200. IF (NS.EQ.0) THEN
  201. C la sous zone de maillage %i1 et de constituant %m1:16 a des
  202. C informations relatives au champ ( infche) erronnées
  203. MOTERR = CONM
  204. INTERR(1) = IPMAIL
  205. CALL ERREUR(877)
  206. GOTO 9999
  207. ENDIF
  208.  
  209. C-- Identification sur les autres critères
  210. IF(NSR.NE.NS .OR. NCOSOR.NE.NS*(NBROBL+NBRFAC))THEN
  211. NSR = NS
  212. NCOSOR= NS * ( NBROBL + NBRFAC )
  213. ** write(6,*) 'komcha ipos nsr ',ipos(/1),nsr
  214. SEGADJ,MPTVAL
  215. ENDIF
  216. C
  217. LECAPA=0
  218. IF (ICOND.EQ.2 .AND. NS.EQ.1 .AND. NBROBL.EQ.1 .AND. NBRFAC.EQ.0)
  219. & LECAPA=1
  220. C
  221. DO JJ=1,NS
  222. ITAB=1
  223. C
  224. C Activation du ICHAML
  225. C
  226. MCHAML=ICHAML(IPOS(JJ))
  227. IF(NOMCHE(/2).NE.1) LECAPA=0
  228. C
  229. C Composantes obligatoires
  230. NSOF(JJ)=0
  231. DO IC1=1,nbrobl
  232. CALL PLACE(NOMCHE,NOMCHE(/2),IPLAC,LESOBL(IC1-ITAB+1))
  233. C DO III=1,NOMCHE(/2)
  234. C PRINT *,'KOMCHA_a:',IC1,':',LESOBL(IC1-ITAB+1),':',
  235. C & III,':',NOMCHE(III),':',IPLAC
  236. C ENDDO
  237. C PRINT *,' '
  238. IF (IPLAC.EQ.0.AND.LECAPA.EQ.1) IPLAC=1
  239. IF (IPLAC.NE.0) THEN
  240. C une seule zone autorisee PV
  241. if (ival(ic1).ne.0) then
  242. interr(1)=ipmail
  243. moterr=conm
  244. call erreur(769)
  245. GOTO 9999
  246. endif
  247. NSOF(JJ)=NSOF(JJ)+1
  248. IVAL(IC1)=IELVAL(IPLAC)
  249. MELVAL=IELVAL(IPLAC)
  250. C Vérification du type si donné
  251. IF (NBTYPE.EQ.0) GO TO 7
  252. ICMN=MIN(IC1,NBTYPE)
  253. IF (TYPE(ICMN).NE.TYPCHE(IPLAC)
  254. $ .AND.TYPE(ICMN).NE.' ') THEN
  255. MOTERR(1:16) = TYPCHE(IPLAC)
  256. MOTERR(17:24) = LESOBL(IC1-ITAB+1)
  257. MOTERR(25:40) = TITCHE
  258. CALL ERREUR(552)
  259. GOTO 9999
  260. ENDIF
  261. 7 TYVAL(IC1)=TYPCHE(IPLAC)
  262. ENDIF
  263. ENDDO
  264. C
  265. C Composantes facultatives
  266. NBOFAC=0
  267. ITAB=ITAB+NBROBL
  268. DO IC2=ITAB,NBRFAC+ITAB-1
  269. IVAL(IC2)=0
  270. CALL PLACE(NOMCHE,NOMCHE(/2),IPLAC,LESFAC(IC2-ITAB+1))
  271. IF (IPLAC.NE.0) THEN
  272. if (ival(ic2).ne.0) then
  273. interr(1)=ipmail
  274. moterr=conm
  275. call erreur(769)
  276. GOTO 9999
  277. ENDIF
  278. NSOF(JJ)=NSOF(JJ)+1
  279. IVAL(IC2)=IELVAL(IPLAC)
  280. MELVAL=IELVAL(IPLAC)
  281. C Vérification du type si donné
  282. IF(NBTYPE.EQ.0) GO TO 8
  283. ICMN=MIN(IC2,NBTYPE)
  284. IF (TYPE(ICMN).NE.TYPCHE(IPLAC)
  285. $ .AND.TYPE(ICMN).NE.' ') THEN
  286. MOTERR(1:16)=TYPCHE(IPLAC)
  287. MOTERR(17:24)=LESFAC(IC2-ITAB+1)
  288. MOTERR(25:40)=TITCHE
  289. CALL ERREUR(552)
  290. GOTO 9999
  291. ENDIF
  292. 8 TYVAL(IC2)=TYPCHE(IPLAC)
  293. NBOFAC=NBOFAC+1
  294. ENDIF
  295. ENDDO
  296.  
  297. CPM si lecture facultative seulement et aucune composante lue
  298. CPM alors renvoie un segment vide (NS=0,NCOSOU=0)
  299. IF (NBROBL.EQ.0 .AND. NBRFAC.GT.0) THEN
  300. IF (NS.EQ.0 .AND. NBOFAC.EQ.0) THEN
  301. NSR = 0
  302. NCOSOR = 0
  303. SEGADJ, MPTVAL
  304. ENDIF
  305. ENDIF
  306.  
  307. CPM ITAB n'est plus utilisé par la suite.
  308. CPM ITAB=ITAB+NBRFAC
  309. C
  310. ENDDO
  311. C verification que les composantes obligatoires sont toutes presentes
  312. DO IC1=1,NBROBL
  313. if (ival(ic1).eq.0) then
  314. IF (ICOND.EQ.1 .OR. ICOND.EQ.2) THEN
  315. MOTERR(1:8) =LESOBL(IC1)
  316. MOTERR(9:16)=TITCHE
  317. CALL ERREUR(77)
  318. ELSE
  319. C Données incompatibles
  320. CALL ERREUR(21)
  321. ENDIF
  322. GOTO 9999
  323. ENDIF
  324. ENDDO
  325. C
  326. 9999 CONTINUE
  327. IF (IERR.NE.0) THEN
  328. CALL DTMVAL(IPTVAL,1)
  329. IPTVAL = 0
  330. ENDIF
  331.  
  332. END
  333.  
  334.  
  335.  
  336.  
  337.  
  338.  
  339.  
  340.  

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