Télécharger exelch.eso

Retour à la liste

Numérotation des lignes :

  1. C EXELCH SOURCE CB215821 16/10/20 21:15:02 9132
  2. SUBROUTINE EXELCH(IPCHEL,IMM,IAB,IAV,ILAST,IPLIS,VALREF,VALRE2,
  3. & IPMAIL)
  4. *
  5. * EXTRAIRE LE OU LES ELEMENTS SUPPORTS DU MAXI OU DU MINI DES VALEURS
  6. * COMPOSANTES D'UN CHAMP/ELEMENT
  7. *
  8. ************************************************************************
  9. * ENTREES :
  10. *
  11. * IPCHEL =POINTEUR SUR UN MCHAML
  12. * IMM = 1 MAXI , 2 MINI , 3 A 8 LES AUTRES
  13. * IAB = 0 VALEURS ALGEBRIQUES ,1 VALEURS ABSOLUES
  14. * IAV = 1 LES NOMS DE LA LISTMOTS SONT CONSIDERES,
  15. * 2 ILS SONT EXCLUS
  16. * ILAST = 1 STRICTEMENT (Tous les PTS de Gauss doivent respecter la condition)
  17. * = 2 LARGEMENT (Un seul PT de Gauss doit respecter la condition)
  18. * IPLIS = POINTEUR SUR UN LISTMOTS
  19. * VALREF = VALEUR POUR FAIRE LES COMPARAISONS
  20. * VALRE2 = IDEM POUR OPTION 'COMPRIS'
  21. *
  22. * SORTIES :
  23. *
  24. * IPMAIL = POINTEUR SUR OBJET MAILLAGE CONTENANT LE OU LES ELEMENTS
  25. * SUPPORTS DU MAXI OU DU MINI OU SATISFAISANT LES TESTS
  26. * PAR RAPPORT A VALREF
  27. *
  28. * P DOWLATYARI OCT 91
  29. ************************************************************************
  30. IMPLICIT INTEGER(I-N)
  31. IMPLICIT REAL*8(A-H,O-Z)
  32. *
  33. -INC CCOPTIO
  34. -INC SMCHAML
  35. -INC SMELEME
  36. -INC SMCOORD
  37. -INC SMLMOTS
  38. *
  39. logical ltelq,BOOL1
  40. SEGMENT QUELCO
  41. INTEGER ICO(NSOUS,NCOMX),NNCO(NSOUS)
  42. ENDSEGMENT
  43. SEGMENT QQQQ
  44. INTEGER ICC(NBEL1)
  45. ENDSEGMENT
  46. *
  47. SEGMENT MESH
  48. INTEGER IMA(NSOUS),IMB(NSOUS)
  49. ENDSEGMENT
  50. *
  51. CHARACTER*4 MOCOMP
  52. *
  53. * INITIALISATIONS
  54. *
  55. IF(IAB.EQ.0)THEN
  56. IF(IMM.EQ.1)THEN
  57. XEXT=-1.D35
  58. ELSE
  59. XEXT=1.D35
  60. ENDIF
  61. ELSE
  62. IF(IMM.EQ.1)THEN
  63. XEXT=0.D0
  64. ELSE
  65. XEXT=1.D35
  66. ENDIF
  67. ENDIF
  68. *
  69. IF(IPLIS.NE.0)THEN
  70. MLMOTS=IPLIS
  71. SEGACT MLMOTS
  72. NC=MOTS(/2)
  73. ENDIF
  74. C
  75. C ON RECUPERE LE CHAMELEM
  76. C
  77. MCHELM=IPCHEL
  78. SEGACT MCHELM
  79. NSOUS=IMACHE(/1)
  80.  
  81. *
  82. * ON CHERCHE LE NOMBRE MAXIMAL DE COMPOSANTES
  83. *
  84. NCOMX = 0
  85. DO 10 ISOUS=1,NSOUS
  86. MCHAML=ICHAML(ISOUS)
  87. SEGACT MCHAML
  88. NCOMX=MAX(NCOMX,NOMCHE(/2))
  89. 10 CONTINUE
  90. *
  91. IF(IPLIS.NE.0)SEGINI QUELCO
  92. *
  93. * BOUCLE SUR LES SOUS-ZONES POUR TROUVER LE MAXI OU LE MINI
  94. *
  95. DO 500 ISOUS=1,NSOUS
  96. *
  97. MCHAML=ICHAML(ISOUS)
  98. NCOMP=NOMCHE(/2)
  99. IF(IPLIS.NE.0)THEN
  100. NCO=0
  101. DO 20 ICOMP=1,NCOMP
  102. MOCOMP=NOMCHE(ICOMP)
  103. CALL PLACE(MOTS,NC,IX,MOCOMP)
  104. IF(IAV.EQ.1)THEN
  105. IF(IX.NE.0)THEN
  106. ICO(ISOUS,ICOMP)=1
  107. NCO=NCO+1
  108. ELSE
  109. ICO(ISOUS,ICOMP)=0
  110. ENDIF
  111. ELSE
  112. IF(IX.EQ.0)THEN
  113. ICO(ISOUS,ICOMP)=1
  114. NCO=NCO+1
  115. ELSE
  116. ICO(ISOUS,ICOMP)=0
  117. ENDIF
  118. ENDIF
  119. 20 CONTINUE
  120. NNCO(ISOUS)=NCO
  121. ENDIF
  122. *
  123. * RECHERCHE DU MAXI OU MINI ( IMM = 1 OU 2 )
  124. *
  125. IF(IMM.LE.2) THEN
  126. *
  127. IF(IPLIS.EQ.0)THEN
  128. DO 100 ICOMP=1,NCOMP
  129. MELVAL=IELVAL(ICOMP)
  130. SEGACT MELVAL
  131. NEL=VELCHE(/2)
  132. NBPTEL=VELCHE(/1)
  133. DO 200 IB=1,NEL
  134. DO 200 IGAU=1,NBPTEL
  135. XX=VELCHE(IGAU,IB)
  136. IF(IAB.EQ.1)XX=ABS(XX)
  137. IF(IMM.EQ.1) THEN
  138. XEXT=MAX(XX,XEXT)
  139. ELSE
  140. XEXT=MIN(XX,XEXT)
  141. ENDIF
  142. 200 CONTINUE
  143. SEGDES MELVAL
  144. 100 CONTINUE
  145. ELSEIF(NCO.NE.0)THEN
  146. DO 110 ICOMP=1,NCOMP
  147. IF(ICO(ISOUS,ICOMP).EQ.1)THEN
  148. MELVAL=IELVAL(ICOMP)
  149. SEGACT MELVAL
  150. NEL=VELCHE(/2)
  151. NBPTEL=VELCHE(/1)
  152. DO 210 IB=1,NEL
  153. DO 210 IGAU=1,NBPTEL
  154. XX=VELCHE(IGAU,IB)
  155. IF(IAB.EQ.1)XX=ABS(XX)
  156. IF(IMM.EQ.1) THEN
  157. XEXT=MAX(XX,XEXT)
  158. ELSE
  159. XEXT=MIN(XX,XEXT)
  160. ENDIF
  161. 210 CONTINUE
  162. SEGDES MELVAL
  163. ENDIF
  164. 110 CONTINUE
  165. ENDIF
  166. *
  167. ENDIF
  168. SEGDES MCHAML
  169. 500 CONTINUE
  170. *
  171. IF(IPLIS.NE.0)THEN
  172. SEGDES MLMOTS
  173. NZERO=0
  174. DO 510 ISOUS=1,NSOUS
  175. IF(NNCO(ISOUS).EQ.0)NZERO=NZERO+1
  176. 510 CONTINUE
  177. IF(NZERO.EQ.NSOUS)THEN
  178. CALL ERREUR(280)
  179. SEGDES MCHELM
  180. SEGSUP QUELCO
  181. IPMAIL=0
  182. RETURN
  183. ENDIF
  184. ENDIF
  185. *
  186. *
  187. * DEUXIEME BOUCLE SUR LES SOUS-ZONES POUR TROUVER LES POINTS SUPPORTS
  188. *
  189. SEGINI MESH
  190. DO 600 ISOUS=1,NSOUS
  191. *
  192. MCHAML=ICHAML(ISOUS)
  193. SEGACT MCHAML
  194. NCOMP=NOMCHE(/2)
  195. IPT1=IMACHE(ISOUS)
  196. SEGACT IPT1
  197. NBNN1=IPT1.NUM(/1)
  198. NBEL1=IPT1.NUM(/2)
  199. NBNN=NBNN1
  200. NBELEM=0
  201. NBSOUS=0
  202. NBREF=0
  203. segini QQQQ
  204. SEGINI MELEME
  205. ITYPEL=IPT1.ITYPEL
  206. IF(IPLIS.EQ.0)THEN
  207. DO 300 ICOMP=1,NCOMP
  208. MELVAL=IELVAL(ICOMP)
  209. SEGACT MELVAL
  210. NBPTEL=VELCHE(/1)
  211. NEL=VELCHE(/2)
  212. DO 400 IB=1,NBEL1
  213. IBMN=MIN(IB,NEL)
  214. DO 401 IGAU=1,NBPTEL
  215. XX=VELCHE(IGAU,IBMN)
  216. IF(IAB.EQ.1)XX=ABS(XX)
  217. *
  218. * TRI SELON LA VALEUR DE IMM
  219. *
  220. GO TO (21,21,23,24,25,26,27,28,29),IMM
  221. *
  222. CALL ERREUR(280)
  223. SEGDES MELVAL
  224. SEGDES MCHELM
  225. SEGSUP QUELCO
  226. IPMAIL=0
  227. RETURN
  228. *
  229. * MAXI OU MINI
  230. 21 BOOL1=(XX.EQ.XEXT)
  231. GOTO 444
  232. *
  233. * SUPE
  234. 23 BOOL1=(XX.GT.VALREF)
  235. GOTO 444
  236. *
  237. * EGSUPE
  238. 24 BOOL1=(XX.GE.VALREF)
  239. GOTO 444
  240. *
  241. * EGAL
  242. 25 BOOL1=(XX.EQ.VALREF)
  243. GOTO 444
  244. *
  245. * EGINFE
  246. 26 BOOL1=(XX.LE.VALREF)
  247. GOTO 444
  248. *
  249. * INFE
  250. 27 BOOL1=(XX.LT.VALREF)
  251. GOTO 444
  252. *
  253. * DIFF
  254. 28 BOOL1=(XX.NE.VALREF)
  255. GOTO 444
  256. *
  257. * COMP
  258. 29 BOOL1=(XX.GE.VALREF) .AND. (XX.LE.VALRE2)
  259. GOTO 444
  260.  
  261. 444 CONTINUE
  262. IF (BOOL1) THEN
  263. IF(ILAST .EQ. 2)THEN
  264. C On prend l''element au premier rencontre
  265. GOTO 403
  266. ELSE
  267. IF (IGAU.EQ.NBPTEL) THEN
  268. C On prend l''element si on arrive au dernier PTS de GAUSS
  269. GOTO 403
  270. ELSE
  271. C On continue sur les PTS de GAUSS
  272. GOTO 401
  273. ENDIF
  274. ENDIF
  275.  
  276. ELSE
  277. IF(ILAST .EQ. 1)THEN
  278. C On change d''element si 'STRI'
  279. GOTO 400
  280. ELSE
  281. IF (IGAU.EQ.NBPTEL) THEN
  282. C On change d''element
  283. GOTO 400
  284. ELSE
  285. C On continue sur les PTS de GAUSS
  286. GOTO 401
  287. ENDIF
  288. ENDIF
  289. ENDIF
  290. 401 CONTINUE
  291. C Fin boucle PTS GAUSS
  292.  
  293. C On n''est pas sense passer la...
  294. CALL ERREUR(21)
  295. RETURN
  296.  
  297. 403 CONTINUE
  298. if (ICC(IB).eq.0) then
  299. icc(ib) = 1
  300. NBELEM=NBELEM+1
  301. SEGADJ MELEME
  302. DO 405 INO=1,NBNN
  303. NUM(INO,NBELEM)=IPT1.NUM(INO,IB)
  304. 405 CONTINUE
  305. ICOLOR(NBELEM)=IPT1.ICOLOR(IB)
  306. ENDIF
  307. 400 CONTINUE
  308. C Fin boucle ELEMENTS
  309.  
  310. SEGDES MELVAL
  311. 300 CONTINUE
  312. *
  313. ELSEIF(NNCO(ISOUS).NE.0)THEN
  314.  
  315. DO 310 ICOMP=1,NCOMP
  316. IF(ICO(ISOUS,ICOMP).EQ.1)THEN
  317. MELVAL=IELVAL(ICOMP)
  318. SEGACT MELVAL
  319. NBPTEL=VELCHE(/1)
  320. NEL=VELCHE(/2)
  321. DO 410 IB=1,NBEL1
  322. IBMN=MIN(IB,NEL)
  323. DO 411 IGAU=1,NBPTEL
  324. XX=VELCHE(IGAU,IBMN)
  325. IF(IAB.EQ.1) XX=ABS(XX)
  326. *
  327. * TRI SELON LA VALEUR DE IMM
  328. *
  329. GO TO (31,31,33,34,35,36,37,38,39),IMM
  330. CALL ERREUR(280)
  331. SEGDES MELVAL
  332. SEGDES MCHELM
  333. SEGSUP QUELCO
  334. IPMAIL=0
  335. RETURN
  336. *
  337. * MAXI OU MINI
  338. 31 BOOL1=(XX.EQ.XEXT)
  339. GOTO 555
  340. *
  341. * SUPE
  342. 33 BOOL1=(XX.GT.VALREF)
  343. GOTO 555
  344. *
  345. * EGSUPE
  346. 34 BOOL1=(XX.GE.VALREF)
  347. GOTO 555
  348. *
  349. * EGAL
  350. 35 BOOL1=(XX.EQ.VALREF)
  351. GOTO 555
  352. *
  353. * EGINFE
  354. 36 BOOL1=(XX.LE.VALREF)
  355. GOTO 555
  356. *
  357. * INFE
  358. 37 BOOL1=(XX.LT.VALREF)
  359. GOTO 555
  360. *
  361. * DIFF
  362. 38 BOOL1=(XX.NE.VALREF)
  363. GOTO 555
  364. *
  365. * COMP
  366. 39 BOOL1=(XX.GE.VALREF) .AND. (XX.LE.VALRE2)
  367. GOTO 555
  368.  
  369. 555 CONTINUE
  370. IF (BOOL1) THEN
  371. IF(ILAST .EQ. 2)THEN
  372. C On prend l''element au premier rencontre
  373. GOTO 413
  374. ELSE
  375. IF (IGAU.EQ.NBPTEL) THEN
  376. C On prend l''element si on arrive au dernier PTS de GAUSS
  377. GOTO 413
  378. ELSE
  379. C On continue sur les PTS de GAUSS
  380. GOTO 411
  381. ENDIF
  382. ENDIF
  383.  
  384. ELSE
  385. IF(ILAST .EQ. 1)THEN
  386. C On change d''element si 'STRI'
  387. GOTO 410
  388. ELSE
  389. IF (IGAU.EQ.NBPTEL) THEN
  390. C On change d''element
  391. GOTO 410
  392. ELSE
  393. C On continue sur les PTS de GAUSS
  394. GOTO 411
  395. ENDIF
  396. ENDIF
  397. ENDIF
  398. 411 CONTINUE
  399. C Fin boucle PTS GAUSS
  400.  
  401. C On n''est pas sense passer la...
  402. CALL ERREUR(21)
  403. RETURN
  404.  
  405. 413 CONTINUE
  406. if (ICC(IB).eq.0) then
  407. icc(ib) = 1
  408. NBELEM=NBELEM+1
  409. SEGADJ MELEME
  410. DO 406 INO=1,NBNN
  411. NUM(INO,NBELEM)=IPT1.NUM(INO,IB)
  412. 406 CONTINUE
  413. ICOLOR(NBELEM)=IPT1.ICOLOR(IB)
  414. endif
  415. *
  416. 410 CONTINUE
  417. SEGDES MELVAL
  418. ENDIF
  419. 310 CONTINUE
  420.  
  421. *
  422. ENDIF
  423.  
  424. SEGDES,MCHAML,IPT1
  425.  
  426. IF(NBELEM.EQ.0)THEN
  427. SEGSUP MELEME
  428. IMA(ISOUS)=0
  429. ELSE
  430. SEGDES MELEME
  431. IMA(ISOUS)=MELEME
  432. IMB(ISOUS)=MELEME
  433. ENDIF
  434. segsup QQQQ
  435. 600 CONTINUE
  436. *
  437. NMAIL=0
  438. DO 610 ISOUS=1,NSOUS
  439. IF(IMA(ISOUS).NE.0)THEN
  440. NMAIL=NMAIL+1
  441. ISOU1=ISOUS
  442. ENDIF
  443. 610 CONTINUE
  444. *
  445. IF(NMAIL.EQ.1)THEN
  446. IPMAIL=IMA(ISOU1)
  447. ELSE
  448. NBSOUS=NMAIL
  449. NBREF =0
  450. NBNN =0
  451. NBELEM=0
  452. SEGINI,MELEME
  453.  
  454. DO ISOUS = 1,NSOUS
  455. IF(IMA(ISOUS).NE.0) THEN
  456. IPP1 = IMA(ISOUS)
  457. ima(isous) = 0
  458. GOTO 618
  459. ENDIF
  460. ENDDO
  461. 618 CONTINUE
  462. *
  463. DO 620 ISOUS=2,NSOUS
  464. ltelq=.false.
  465. IF (IMA(ISOUS).NE.0) THEN
  466. IPP2 = IMA(ISOUS)
  467. CALL FUSE(IPP1,IPP2,MELEME,ltelq)
  468. ipt1 = ipp1
  469. segdes ipt1
  470. IPP1 = MELEME
  471. ENDIF
  472. 620 CONTINUE
  473.  
  474. SEGACT,MELEME
  475. NBSOUS=LISOUS(/1)
  476. DO ISOUS = 1,NSOUS
  477. IPT1 = IMB(ISOUS)
  478. IF (NBSOUS.EQ.0) THEN
  479. IF (IPT1.EQ.MELEME) GOTO 621
  480. ELSE
  481. DO IZ = 1,NBSOUS
  482. IF (IPT1.EQ.LISOUS(IZ)) GOTO 621
  483. ENDDO
  484. ENDIF
  485. SEGSUP IPT1
  486. 621 CONTINUE
  487. ENDDO
  488. SEGDES MELEME
  489. IPMAIL=MELEME
  490. ENDIF
  491. SEGDES MCHELM
  492. IF(IPLIS.NE.0)SEGSUP QUELCO
  493. SEGSUP MESH
  494.  
  495. RETURN
  496. END
  497.  
  498.  

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