Télécharger exelch.eso

Retour à la liste

Numérotation des lignes :

  1. C EXELCH SOURCE PASCAL 18/11/29 21:15:01 10014
  2. *
  3. * EXTRAIRE LE OU LES ELEMENTS SUPPORTS DU MAXI OU DU MINI DES VALEURS
  4. * COMPOSANTES D'UN CHAMP/ELEMENT
  5. *
  6. ************************************************************************
  7. * ENTREES :
  8. *
  9. * IPCHEL =POINTEUR SUR UN MCHAML
  10. * IMM = 1 MAXI , 2 MINI , 3 A 9 LES AUTRES
  11. * IAB = 0 VALEURS ALGEBRIQUES ,1 VALEURS ABSOLUES
  12. * IAV = 1 LES NOMS DE LA LISTMOTS SONT CONSIDERES,
  13. * 2 ILS SONT EXCLUS
  14. * ILAST = 1 STRICTEMENT (Tous les PTS de Gauss doivent respecter la condition)
  15. * = 2 LARGEMENT (Un seul PT de Gauss doit respecter la condition)
  16. * IPLIS = POINTEUR SUR UN LISTMOTS
  17. * VALREF = VALEUR POUR FAIRE LES COMPARAISONS
  18. * VALRE2 = IDEM POUR OPTION 'COMPRIS'
  19. *
  20. * SORTIES :
  21. *
  22. * IPMAIL = POINTEUR SUR OBJET MAILLAGE CONTENANT LE OU LES ELEMENTS
  23. * SUPPORTS DU MAXI OU DU MINI OU SATISFAISANT LES TESTS
  24. * PAR RAPPORT A VALREF
  25. *
  26. * P DOWLATYARI OCT 91
  27. ************************************************************************
  28. SUBROUTINE EXELCH(IPCHEL,IMM,IAB,IAV,ILAST,IPLIS,VALREF,VALRE2,
  29. & IPMAIL)
  30.  
  31. IMPLICIT INTEGER(I-N)
  32. IMPLICIT REAL*8(A-H,O-Z)
  33.  
  34. -INC CCOPTIO
  35. -INC CCREEL
  36.  
  37. -INC SMCHAML
  38. -INC SMELEME
  39. -INC SMLMOTS
  40.  
  41. SEGMENT QUELCO
  42. INTEGER ICO(NSOUS,NCOMX),NNCO(NSOUS),IMEL(NSOUS)
  43. ENDSEGMENT
  44.  
  45. SEGMENT MMEL
  46. INTEGER NELC,LELC(NBELC)
  47. ENDSEGMENT
  48.  
  49. SEGMENT MESH
  50. INTEGER LMAIL(NMAIL,3+NSOUS)
  51. ENDSEGMENT
  52.  
  53. LOGICAL BOOL1
  54. CHARACTER*8 MOCOMP
  55.  
  56. * INITIALISATIONS
  57. IPMAIL = 0
  58. *
  59. IMAIL = 0
  60. QUELCO = 0
  61. MESH = 0
  62.  
  63. * VERIFICATIONS D'USAGE (normalement inutiles) :
  64. IF (IMM.LT.1 .OR. IMM.GT.9) THEN
  65. write(ioimp,*) 'EXELCH IMM =',IMM
  66. CALL ERREUR(5)
  67. RETURN
  68. ENDIF
  69. IF (IAB.LT.0 .OR. IAB.GT.1) THEN
  70. write(ioimp,*) 'EXELCH IAB =',IAB
  71. CALL ERREUR(5)
  72. RETURN
  73. ENDIF
  74. IF (IAV.LT.1 .OR. IAV.GT.2) THEN
  75. write(ioimp,*) 'EXELCH IAV =',IAV
  76. CALL ERREUR(5)
  77. RETURN
  78. ENDIF
  79. IF (ILAST.LT.1 .OR. ILAST.GT.2) THEN
  80. write(ioimp,*) 'EXELCH ILAST =',ILAST
  81. CALL ERREUR(5)
  82. RETURN
  83. ENDIF
  84.  
  85. * ON RECUPERE LE CHAMP PAR ELEMENT
  86. *
  87. MCHELM = IPCHEL
  88. SEGACT,MCHELM
  89. NSOUS = mchelm.IMACHE(/1)
  90. * MCHAML vide -> Maillage vide en sortie
  91. IF (NSOUS.EQ.0) GOTO 90
  92.  
  93. * ON CHERCHE LE NOMBRE MAXIMAL DE COMPOSANTES
  94. *
  95. NCOMX = 0
  96. DO 10 ISOUS = 1, NSOUS
  97. mchaml = mchelm.ICHAML(ISOUS)
  98. SEGACT,mchaml
  99. NCOMX = MAX(NCOMX,mchaml.NOMCHE(/2))
  100. 10 CONTINUE
  101. * MCHAML sans composante -> Maillage vide en sortie
  102. IF (NCOMX.EQ.0) GOTO 90
  103. SEGINI,QUELCO
  104.  
  105. * Remplissage de QUELCO qui indique les composantes a prendre en compte
  106. * sur chaque sous-zone
  107. * Par defaut, on prend toutes les composantes, sauf si la listmots est
  108. * fournie, et dans ce cas, on conserve ou on exclut les composantes.
  109. *
  110. IF (IPLIS.NE.0) THEN
  111. mlmots = IPLIS
  112. SEGACT,mlmots
  113. NCLIS = mlmots.MOTS(/2)
  114. ENDIF
  115.  
  116. NZERO = NSOUS
  117. DO 20 ISOUS = 1, NSOUS
  118. MELEME = mchelm.IMACHE(ISOUS)
  119. MCHAML = mchelm.ICHAML(ISOUS)
  120. NCOMP = mchaml.NOMCHE(/2)
  121. IF (IPLIS.EQ.0) THEN
  122. DO ICOMP = 1, NCOMP
  123. quelco.ICO(ISOUS,ICOMP) = 1
  124. ENDDO
  125. NCO = NCOMP
  126. ELSE
  127. NCO = 0
  128. DO ICOMP = 1, NCOMP
  129. MOCOMP = mchaml.NOMCHE(ICOMP)
  130. CALL PLACE(mlmots.MOTS,NCLIS,IX,MOCOMP)
  131. igco = 0
  132. IF (IAV.EQ.1) THEN
  133. IF (IX.NE.0) igco = 1
  134. ELSE
  135. IF (IX.EQ.0) igco = 1
  136. ENDIF
  137. quelco.ICO(ISOUS,ICOMP) = igco
  138. NCO = NCO + igco
  139. ENDDO
  140. ENDIF
  141. quelco.NNCO(ISOUS) = NCO
  142. IF (NCO.NE.0) THEN
  143. c* On verifie si MELEME n'a pas deja ete rencontre dans les sous-zones
  144. c* precedentes...
  145. mmel = 0
  146. DO ISZ = ISOUS-1, 1, -1
  147. IF (meleme.EQ.mchelm.IMACHE(ISZ)) THEN
  148. mmel = -ABS(quelco.IMEL(ISZ))
  149. ENDIF
  150. ENDDO
  151. IF (mmel.EQ.0) THEN
  152. SEGACT,meleme
  153. NBELC = meleme.NUM(/2)
  154. c* SEGDES,meleme
  155. SEGINI,mmel
  156. ENDIF
  157. ELSE
  158. mmel = 0
  159. NZERO = NZERO - 1
  160. ENDIF
  161. quelco.IMEL(ISOUS) = mmel
  162. 20 CONTINUE
  163.  
  164. IF (IPLIS.NE.0) THEN
  165. SEGDES,mlmots
  166. ENDIF
  167. * Cas particulier ou aucune composante n'est a traiter -> Maillage Vide
  168. IF (NZERO.EQ.0) GOTO 90
  169.  
  170. * RECHERCHE DU MAXI OU MINI ( IMM = 1 OU 2 )
  171. *
  172. IF (IMM.LE.2) THEN
  173. IF (IMM.EQ.1) THEN
  174. IF (IAB.EQ.0) THEN
  175. XEXT = -XGRAND
  176. ELSE
  177. XEXT = XZERO
  178. ENDIF
  179. ELSE
  180. XEXT = XGRAND
  181. ENDIF
  182.  
  183. DO 30 ISOUS = 1, NSOUS
  184. IF (quelco.NNCO(ISOUS).EQ.0) GOTO 30
  185. MCHAML = mchelm.ICHAML(ISOUS)
  186. NCOMP = mchaml.NOMCHE(/2)
  187. DO 310 ICOMP = 1, NCOMP
  188. IF (quelco.ICO(ISOUS,ICOMP).EQ.0) GOTO 310
  189. melval = mchaml.IELVAL(ICOMP)
  190. SEGACT,melval
  191. NBPTEL = melval.VELCHE(/1)
  192. NEL = melval.VELCHE(/2)
  193. DO 320 IB = 1, NEL
  194. DO 320 IGAU = 1,NBPTEL
  195. XX = melval.VELCHE(IGAU,IB)
  196. IF (IAB.EQ.1) XX = ABS(XX)
  197. IF (IMM.EQ.1) THEN
  198. XEXT = MAX(XX,XEXT)
  199. ELSE
  200. XEXT = MIN(XX,XEXT)
  201. ENDIF
  202. 320 CONTINUE
  203. c* SEGDES,melval
  204. 310 CONTINUE
  205. 30 CONTINUE
  206. ENDIF
  207.  
  208. * BOUCLE SUR LES SOUS-ZONES POUR TROUVER LES POINTS SUPPORTS
  209. *
  210. DO 40 ISOUS = 1, NSOUS
  211. IF (quelco.NNCO(ISOUS).EQ.0) GOTO 40
  212. mmel = ABS(quelco.IMEL(ISOUS))
  213. * segact,mmel
  214. NBELC = mmel.LELC(/1)
  215. c* Si NELC = NBELC c'est que tous les elements du maillage sont deja
  216. c* pris auparavant (meleme commun a plusieurs sous-zones) donc on
  217. c* ne poursuit plus le traitement pour cette sous-zone...
  218. IF (mmel.NELC.EQ.NBELC) GOTO 40
  219. MCHAML = mchelm.ICHAML(ISOUS)
  220. NCOMP = mchaml.NOMCHE(/2)
  221. DO 410 ICOMP = 1, NCOMP
  222. IF (quelco.ICO(ISOUS,ICOMP).EQ.0) GOTO 410
  223. c* Si NELC = NBELC c'est que tous les elements sont deja pris pour
  224. c* les precedentes composantes de cette sous-zone...
  225. IF (mmel.NELC.EQ.NBELC) GOTO 40
  226. melval = mchaml.IELVAL(ICOMP)
  227. SEGACT,melval
  228. NBPTEL = melval.VELCHE(/1)
  229. NEL = melval.VELCHE(/2)
  230. c* Normalement : NEL = 1 ou NEL = NBELC (a verifier ?)
  231. DO 420 IB = 1, NBELC
  232. C* Si l'element a deja ete retenu, ce n'est pas la peine de continuer...
  233. IF (mmel.LELC(IB).EQ.1) GOTO 420
  234. IBMN = MIN(IB,NEL)
  235. igco = 0
  236. DO 430 IGAU = 1, NBPTEL
  237. XX = melval.VELCHE(IGAU,IBMN)
  238. IF (IAB.EQ.1) XX = ABS(XX)
  239.  
  240. * TRI SELON LA VALEUR DE IMM
  241. GOTO (21,21,23,24,25,26,27,28,29),IMM
  242. c* Erreur ne devant pas arriver normalement (voir test au debut)
  243. CALL ERREUR(5)
  244. GOTO 9000
  245.  
  246. * MAXI OU MINI
  247. 21 BOOL1 = (XX.EQ.XEXT)
  248. GOTO 425
  249. * SUPE
  250. 23 BOOL1 = (XX.GT.VALREF)
  251. GOTO 425
  252. * EGSUPE
  253. 24 BOOL1 = (XX.GE.VALREF)
  254. GOTO 425
  255. * EGAL
  256. 25 BOOL1 = (XX.EQ.VALREF)
  257. GOTO 425
  258. * EGINFE
  259. 26 BOOL1 = (XX.LE.VALREF)
  260. GOTO 425
  261. * INFE
  262. 27 BOOL1 = (XX.LT.VALREF)
  263. GOTO 425
  264. * DIFF
  265. 28 BOOL1 = (XX.NE.VALREF)
  266. GOTO 425
  267. * COMP
  268. 29 BOOL1 = (XX.GE.VALREF) .AND. (XX.LE.VALRE2)
  269. GOTO 425
  270. *
  271. 425 CONTINUE
  272. IF (BOOL1) THEN
  273. igco = igco + 1
  274. C On prend l'element au premier rencontre car LARG
  275. IF (ILAST.EQ.2) GOTO 435
  276. ELSE
  277. C On change d''element si 'STRI'
  278. IF (ILAST.EQ.1) GOTO 420
  279. ENDIF
  280. 430 CONTINUE
  281. 435 IF (igco.GT.0) THEN
  282. mmel.LELC(IB) = 1
  283. mmel.NELC = mmel.NELC + 1
  284. ENDIF
  285. 420 CONTINUE
  286. SEGDES,melval
  287. 410 CONTINUE
  288. 40 CONTINUE
  289.  
  290. C* Il faut maintenant construire le maillage correspondant :
  291. NMAIL = NSOUS
  292. SEGINI,MESH
  293. IMAIL = 0
  294. DO 500 ISOUS = 1, NSOUS
  295. mmel = quelco.IMEL(ISOUS)
  296. IF (mmel.LE.0) GOTO 500
  297. * segact,mmel
  298. IF (mmel.NELC.EQ.0) GOTO 500
  299. ipt1 = mchelm.IMACHE(ISOUS)
  300. * segact,ipt1
  301. ity1 = ipt1.ITYPEL
  302. nbn1 = ipt1.NUM(/1)
  303. DO im = 1, IMAIL
  304. IF (ity1.EQ.mesh.LMAIL(im,1) .AND.
  305. & nbn1.EQ.mesh.LMAIL(im,2)) THEN
  306. C* Le 2e test sert dans le cas particulier des elements SURE pour
  307. C* lesquels itypel=48 mais le nombre de noeuds variables !
  308. IMSH = im
  309. GOTO 510
  310. ENDIF
  311. ENDDO
  312. IMAIL = IMAIL + 1
  313. IMSH = IMAIL
  314. mesh.LMAIL(IMSH,1) = ity1
  315. mesh.LMAIL(IMSH,2) = nbn1
  316. mesh.LMAIL(IMSH,3) = 0
  317. 510 CONTINUE
  318. mesh.LMAIL(IMSH,3+ISOUS) = mesh.LMAIL(IMSH,3) + 1
  319. mesh.LMAIL(IMSH,3) = mesh.LMAIL(IMSH,3) + mmel.NELC
  320. 500 CONTINUE
  321. *
  322. * Cas particulier : le maillage resultat est vide
  323. 90 CONTINUE
  324. IF (IMAIL.EQ.0) THEN
  325. NBNN = 0
  326. NBELEM = 0
  327. NBSOUS = 0
  328. NBREF = 0
  329. SEGINI,meleme
  330. meleme.ITYPEL = 0
  331. ELSE
  332. IF (IMAIL.GT.1)THEN
  333. NBNN = 0
  334. NBELEM = 0
  335. NBSOUS = IMAIL
  336. NBREF = 0
  337. SEGINI,meleme
  338. ENDIF
  339. DO 600 IMSH = 1, IMAIL
  340. NBNN = mesh.LMAIL(IMSH,2)
  341. NBELEM = mesh.LMAIL(IMSH,3)
  342. NBSOUS = 0
  343. NBREF = 0
  344. SEGINI,ipt3
  345. ipt3.ITYPEL = mesh.LMAIL(IMSH,1)
  346. js = 0
  347. jm = 0
  348. DO 610 ISOUS = 1, NSOUS
  349. im = mesh.LMAIL(IMSH,3+ISOUS)
  350. IF (im.EQ.0) GOTO 610
  351. im = im - 1
  352. ipt2 = mchelm.IMACHE(ISOUS)
  353. NBEL2 = ipt2.NUM(/2)
  354. mmel = quelco.IMEL(ISOUS)
  355. c* Quelques tests de verification/debogage au cas ou :
  356. if (mmel.LE.0) then
  357. write(ioimp,*) 'exelch : err 610 mmel',mmel,isous,imsh
  358. call erreur(5)
  359. endif
  360. nbnn2 = ipt2.NUM(/1)
  361. if (nbnn2.NE.nbnn) then
  362. write(ioimp,*) 'exelch : err 610 nbnn',nbnn2,nbnn,isous,imsh
  363. call erreur(5)
  364. endif
  365. nbelc = mmel.LELC(/1)
  366. if (NBEL2.NE.nbelc) then
  367. write(ioimp,*) 'exelch : err 610 nbel',nbelc,nbel2,isous,imsh
  368. call erreur(5)
  369. endif
  370. js = js + 1
  371. DO 620 IB = 1, NBEL2
  372. IF (mmel.LELC(IB).EQ.0) GOTO 620
  373. im = im + 1
  374. jm = jm + 1
  375. DO igau = 1, NBNN
  376. ipt3.NUM(igau,im) = ipt2.NUM(igau,IB)
  377. ENDDO
  378. ipt3.ICOLOR(im) = ipt2.ICOLOR(IB)
  379. 620 CONTINUE
  380. 610 CONTINUE
  381. if (jm.ne.NBELEM) then
  382. write(ioimp,*) 'exelch : incoherence jm',jm,nbelem,imsh
  383. call erreur(5)
  384. endif
  385. IF (js.GT.1) THEN
  386. CALL UNIQM1(ipt3,ipt1,nbdif)
  387. IF (IPT1.NE.IPT3) SEGSUP,ipt3
  388. c* if (ipt1.eq.0) then
  389. c* write(ioimp,*) 'exelch : maillage vide',imsh
  390. c* endif
  391. ELSE
  392. ipt1 = ipt3
  393. ENDIF
  394. IF (IMAIL.GT.1) THEN
  395. meleme.LISOUS(IMSH) = ipt1
  396. segdes,ipt1
  397. ENDIF
  398. 600 CONTINUE
  399. IF (IMAIL.EQ.1) meleme = ipt1
  400. ENDIF
  401. SEGDES,meleme
  402. IPMAIL = meleme
  403. IF (mesh.NE.0) SEGSUP,mesh
  404.  
  405. 9000 CONTINUE
  406. DO ISOUS = 1, NSOUS
  407. meleme = mchelm.IMACHE(ISOUS)
  408. mchaml = mchelm.ICHAML(ISOUS)
  409. SEGDES,mchaml,meleme
  410. mmel = quelco.IMEL(ISOUS)
  411. IF (mmel.GT.0) SEGSUP,mmel
  412. ENDDO
  413. SEGDES,MCHELM
  414. IF (quelco.NE.0) SEGSUP,quelco
  415.  
  416. RETURN
  417. END
  418.  
  419.  
  420.  
  421.  

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