Télécharger komcha.eso

Retour à la liste

Numérotation des lignes :

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

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