Télécharger komcha.eso

Retour à la liste

Numérotation des lignes :

komcha
  1. C KOMCHA SOURCE PV090527 24/04/04 21:15:20 11875
  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 write (6,*) ' komcha i conm conche',i,conm,conche(i)
  136. IF ( IPMAIL.NE.IMACHE(I) .OR.
  137. & (INS.GE.1.AND.CONM.NE.CONCHE(I)) ) GOTO 1
  138. cjk148537 & (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. if (icond.gt.0) then
  165. C On n'a pas trouvé, dans un CHAMELEM, de zone géométrique ou
  166. C de constituant correspondant à l'objet MODELE
  167. CALL ERREUR(472)
  168. else
  169. NSR = 0
  170. NCOSOR = 0
  171. SEGADJ, MPTVAL
  172. endif
  173. GOTO 9999
  174. ENDIF
  175.  
  176. C on a trouvé un sous-maillage
  177. MCHELM=IPTRET
  178. N1 = IMACHE(/1)
  179. N3 = INFCHE(/2)
  180. NN3 = MIN(N3,NINFO)
  181. C
  182. C ON VERIFIE A NOUVEAU LA COMPATIBILITE DES INFOS
  183. C
  184. DO 11 I=1,N1
  185. IF (NN3.EQ.0) THEN
  186. NS=NS+1
  187. C write (6,*) ' komcha-3 ns i ',ns,i
  188. ELSE
  189. DO J=1,NN3
  190. C test numéro d'harmonique
  191. IF (INFOS(J).NE.INFCHE(I,J).AND.(IHA.NE.INFCHE(I,J))) GOTO 11
  192. ENDDO
  193. NS=NS+1
  194. C write (6,*) ' komcha-4 ns i j ',ns,i,j
  195. ENDIF
  196. IF (NS.GT.NSR) THEN
  197. NSR = NS*2
  198. ** write(6,*) ' extension 2 ',ns,nsr
  199. SEGADJ MPTVAL
  200. ENDIF
  201. IPOS(NS) = I
  202. 11 CONTINUE
  203. ENDIF
  204. C
  205. C TEST SUR LA NULLITE DE NS AM
  206. IF (NS.EQ.0) THEN
  207. C la sous zone de maillage %i1 et de constituant %m1:16 a des
  208. C informations relatives au champ ( infche) erronnées
  209. MOTERR = CONM
  210. INTERR(1) = IPMAIL
  211. CALL ERREUR(877)
  212. GOTO 9999
  213. ENDIF
  214.  
  215. C-- Identification sur les autres critères
  216. IF(NSR.NE.NS .OR. NCOSOR.NE.NS*(NBROBL+NBRFAC))THEN
  217. NSR = NS
  218. NCOSOR= NS * ( NBROBL + NBRFAC )
  219. ** write(6,*) 'komcha ipos nsr ',ipos(/1),nsr
  220. SEGADJ,MPTVAL
  221. ENDIF
  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. 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. C DO III=1,NOMCHE(/2)
  240. C PRINT *,'KOMCHA_a:',IC1,':',LESOBL(IC1-ITAB+1),':',
  241. C & III,':',NOMCHE(III),':',IPLAC
  242. C ENDDO
  243. C PRINT *,' '
  244. IF (IPLAC.EQ.0.AND.LECAPA.EQ.1) IPLAC=1
  245. IF (IPLAC.NE.0) THEN
  246. C une seule zone autorisee PV
  247. if (ival(ic1).ne.0) then
  248. interr(1)=ipmail
  249. moterr=conm
  250. call erreur(769)
  251. GOTO 9999
  252. endif
  253. NSOF(JJ)=NSOF(JJ)+1
  254. IVAL(IC1)=IELVAL(IPLAC)
  255. MELVAL=IELVAL(IPLAC)
  256. C Vérification du type si donné
  257. IF (NBTYPE.EQ.0) GO TO 7
  258. ICMN=MIN(IC1,NBTYPE)
  259. IF (TYPE(ICMN).NE.TYPCHE(IPLAC)
  260. $ .AND.TYPE(ICMN).NE.' ') THEN
  261. MOTERR(1:16) = TYPCHE(IPLAC)
  262. MOTERR(17:24) = LESOBL(IC1-ITAB+1)
  263. MOTERR(25:40) = TITCHE
  264. CALL ERREUR(552)
  265. GOTO 9999
  266. ENDIF
  267. 7 TYVAL(IC1)=TYPCHE(IPLAC)
  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. * verif iplac pas deja rencontre: lesfac en double
  288. do ic3=itab,ic2-1
  289. if(lesfac(ic2-itab+1).eq.lesfac(ic3-itab+1)) then
  290. write(6,*) 'ic2 ic3 melval ielval',ic2,ic3,
  291. > melval,ielval(ic3)
  292. moterr(1:16)=lesfac(ic2-itab+1)
  293. call erreur(1144)
  294. goto 9999
  295. endif
  296. enddo
  297. C Vérification du type si donné
  298. IF(NBTYPE.EQ.0) GO TO 8
  299. ICMN=MIN(IC2,NBTYPE)
  300. IF (TYPE(ICMN).NE.TYPCHE(IPLAC)
  301. $ .AND.TYPE(ICMN).NE.' ') THEN
  302. MOTERR(1:16)=TYPCHE(IPLAC)
  303. MOTERR(17:24)=LESFAC(IC2-ITAB+1)
  304. MOTERR(25:40)=TITCHE
  305. CALL ERREUR(552)
  306. GOTO 9999
  307. ENDIF
  308. 8 TYVAL(IC2)=TYPCHE(IPLAC)
  309. NBOFAC=NBOFAC+1
  310. ENDIF
  311. ENDDO
  312.  
  313. CPM si lecture facultative seulement et aucune composante lue
  314. CPM alors renvoie un segment vide (NS=0,NCOSOU=0)
  315. IF (NBROBL.EQ.0 .AND. NBRFAC.GT.0) THEN
  316. * write(6,*) 'komcxha',ns,nbofac
  317. IF (NS.EQ.0 .AND. NBOFAC.EQ.0) THEN
  318. NSR = 0
  319. NCOSOR = 0
  320. SEGADJ, MPTVAL
  321. ENDIF
  322. c IF (NBOFAC.EQ.0) THEN
  323. c ncosor = 0
  324. c segadj,mptval
  325. c ENDIF
  326. ENDIF
  327.  
  328. CPM ITAB n'est plus utilisé par la suite.
  329. CPM ITAB=ITAB+NBRFAC
  330. C
  331. ENDDO
  332. C verification que les composantes obligatoires sont toutes presentes
  333. DO IC1=1,NBROBL
  334. c write(6,*) 'kx4', lesobl(ic1),ival(ic1)
  335. IF (ival(ic1).eq.0) then
  336. IF (ICOND.EQ.1 .OR. ICOND.EQ.2) THEN
  337. MOTERR(1:8) =LESOBL(IC1)
  338. MOTERR(9:16)=TITCHE
  339. CALL ERREUR(77)
  340. ELSE
  341. C Données incompatibles
  342. CALL ERREUR(21)
  343. ENDIF
  344. GOTO 9999
  345. ENDIF
  346. ENDDO
  347. C
  348. 9999 CONTINUE
  349. IF (IERR.NE.0) THEN
  350. CALL DTMVAL(IPTVAL,1)
  351. IPTVAL = 0
  352. ENDIF
  353.  
  354. END
  355.  
  356.  
  357.  
  358.  
  359.  
  360.  
  361.  
  362.  
  363.  
  364.  
  365.  

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