Télécharger expche.eso

Retour à la liste

Numérotation des lignes :

  1. C EXPCHE SOURCE CB215821 19/08/20 21:17:29 10287
  2. SUBROUTINE EXPCHE(IPCHEL,IMM,IAB,IAV,IPLIS,VALREF,VALRE2,IPMAIL)
  3. *
  4. * EXTRAIRE LE OU LES POINTS SUPPORTS DU MAXI OU DU MINI DES VALEURS DE
  5. * COMPOSANTES D'UN CHAMP/ELEMENT
  6. *
  7. ************************************************************************
  8. * ENTREES :
  9. *
  10. * IPCHEL =POINTEUR SUR UN MCHAML
  11. * IMM = 1 MAXI , 2 MINI , 3 A 8 AUTRES
  12. * IAB = 0 VALEURS ALGEBRIQUES ,1 VALEURS ABSOLUES
  13. * IAV = 1 LES NOMS DE LA LISEMOTS SONT CONSIDERES ,2 ILS SONT EXC
  14. * IPLIS = POINTEUR SUR UN LISTMOTS
  15. * VALREF = VALEUR DE REFERENCE
  16. * VALRE2 = IDEM POUR OPTION COMPRIS
  17. *
  18. * SORTIES :
  19. *
  20. * IPMAIL = POINTEUR SUR OBJET MAILLAGE CONTENANT LE OU LES POINTS
  21. * SUPPORTS DU MAXI OU DU MINI
  22. *
  23. * P DOWLATYARI OCT 91
  24. ************************************************************************
  25. IMPLICIT INTEGER(I-N)
  26. IMPLICIT REAL*8(A-H,O-Z)
  27. *
  28. -INC CCOPTIO
  29. -INC SMCHAML
  30. -INC SMELEME
  31. -INC SMCOORD
  32. -INC SMLMOTS
  33. -INC SMINTE
  34. *
  35. SEGMENT QUELCO
  36. INTEGER ICO(NSOUS,NCOMX),NNCO(NSOUS)
  37. ENDSEGMENT
  38. *
  39. SEGMENT MTRA
  40. REAL*8 XE(3,NBNN1)
  41. ENDSEGMENT
  42. *
  43. CHARACTER*4 MOCOMP
  44. *
  45. * INITIALISATIONS
  46. *
  47. IF(IAB.EQ.0)THEN
  48. IF(IMM.EQ.1)THEN
  49. XEXT=-1.D35
  50. ELSE
  51. XEXT=1.D35
  52. ENDIF
  53. ELSE
  54. IF(IMM.EQ.1)THEN
  55. XEXT=0.D0
  56. ELSE
  57. XEXT=1.D35
  58. ENDIF
  59. ENDIF
  60. *
  61. IF(IPLIS.NE.0)THEN
  62. MLMOTS=IPLIS
  63. SEGACT MLMOTS
  64. NC=MOTS(/2)
  65. ENDIF
  66. C
  67. C ON RECUPERE LE CHAMELEM
  68. C
  69. MCHELM=IPCHEL
  70. SEGACT MCHELM
  71. NSOUS=IMACHE(/1)
  72.  
  73. *
  74. * ON CHERCHE LE NOMBRE MAXIMALE DE COMPOSANTES
  75. *
  76. NCOMX = 0
  77. DO 10 ISOUS=1,NSOUS
  78. MCHAML=ICHAML(ISOUS)
  79. SEGACT MCHAML
  80. NCOMX=MAX(NCOMX,NOMCHE(/2))
  81. 10 CONTINUE
  82. *
  83. IF(IPLIS.NE.0)SEGINI QUELCO
  84. *
  85. * BOUCLE SUR LES SOUS-ZONES POUR TROUVER LE MAXI OU LE MINI
  86. *
  87. DO 500 ISOUS=1,NSOUS
  88. *
  89. MCHAML=ICHAML(ISOUS)
  90. NCOMP=NOMCHE(/2)
  91. IF(IPLIS.NE.0)THEN
  92. NCO=0
  93. DO 20 ICOMP=1,NCOMP
  94. MOCOMP=NOMCHE(ICOMP)
  95. CALL PLACE(MOTS,NC,IX,MOCOMP)
  96. IF(IAV.EQ.1)THEN
  97. IF(IX.NE.0)THEN
  98. ICO(ISOUS,ICOMP)=1
  99. NCO=NCO+1
  100. ELSE
  101. ICO(ISOUS,ICOMP)=0
  102. ENDIF
  103. ELSE
  104. IF(IX.EQ.0)THEN
  105. ICO(ISOUS,ICOMP)=1
  106. NCO=NCO+1
  107. ELSE
  108. ICO(ISOUS,ICOMP)=0
  109. ENDIF
  110. ENDIF
  111. 20 CONTINUE
  112. NNCO(ISOUS)=NCO
  113. ENDIF
  114. *
  115. IF(IMM.LE.2) THEN
  116. IF(IPLIS.EQ.0)THEN
  117. DO 100 ICOMP=1,NCOMP
  118. MELVAL=IELVAL(ICOMP)
  119. SEGACT MELVAL
  120. NEL=VELCHE(/2)
  121. NBPTEL=VELCHE(/1)
  122. DO 200 IB=1,NEL
  123. DO 200 IGAU=1,NBPTEL
  124. XX=VELCHE(IGAU,IB)
  125. IF(IAB.EQ.1) XX = ABS(XX)
  126. IF(IMM.EQ.1)THEN
  127. XEXT=MAX(XX,XEXT)
  128. ELSE
  129. XEXT=MIN(XX,XEXT)
  130. ENDIF
  131. 200 CONTINUE
  132. 100 CONTINUE
  133. ELSEIF(NCO.NE.0)THEN
  134. DO 110 ICOMP=1,NCOMP
  135. IF(ICO(ISOUS,ICOMP).EQ.1)THEN
  136. MELVAL=IELVAL(ICOMP)
  137. SEGACT MELVAL
  138. NEL=VELCHE(/2)
  139. NBPTEL=VELCHE(/1)
  140. DO 210 IB=1,NEL
  141. DO 210 IGAU=1,NBPTEL
  142. XX=VELCHE(IGAU,IB)
  143. IF(IAB.EQ.1) XX = ABS(XX)
  144. IF(IMM.EQ.1)THEN
  145. XEXT=MAX(XX,XEXT)
  146. ELSE
  147. XEXT=MIN(XX,XEXT)
  148. ENDIF
  149. 210 CONTINUE
  150. ENDIF
  151. 110 CONTINUE
  152. ENDIF
  153. ENDIF
  154. 500 CONTINUE
  155. *
  156. IF(IPLIS.NE.0)THEN
  157. NZERO=0
  158. DO 510 ISOUS=1,NSOUS
  159. IF(NNCO(ISOUS).EQ.0)NZERO=NZERO+1
  160. 510 CONTINUE
  161. IF(NZERO.EQ.NSOUS)THEN
  162. CALL ERREUR(280)
  163. SEGSUP QUELCO
  164. IPMAIL=0
  165. RETURN
  166. ENDIF
  167. ENDIF
  168. *
  169. * CREATION DE L'OBJET MAILLAGE CONTENANT LES POINTS SUPPORTS
  170. *
  171. NBNN=1
  172. NBELEM=XCOOR(/1)/(IDIM+1)
  173. NBTEST=NBELEM
  174. NBSOUS=0
  175. NBREF=0
  176. SEGINI MELEME
  177. IPMAIL=MELEME
  178. ITYPEL=1
  179. NBELEM=0
  180. *
  181. * DEUXIEME BOUCLE SUR LES SOUS-ZONES POUR TROUVER LES POINTS SUPPORTS
  182. *
  183. DO 600 ISOUS=1,NSOUS
  184. *
  185. MCHAML=ICHAML(ISOUS)
  186. SEGACT MCHAML
  187. NCOMP=NOMCHE(/2)
  188. MINTE=INFCHE(ISOUS,4)
  189. IF(MINTE.NE.0)THEN
  190. SEGACT MINTE
  191. NBNO=SHPTOT(/2)
  192. ENDIF
  193. IPT1=IMACHE(ISOUS)
  194. SEGACT IPT1
  195. NBNN1=IPT1.NUM(/1)
  196. IF(MINTE.NE.0)SEGINI MTRA
  197. IF(IPLIS.EQ.0)THEN
  198. DO 300 ICOMP=1,NCOMP
  199. MELVAL=IELVAL(ICOMP)
  200. SEGACT MELVAL
  201. NBPTEL=VELCHE(/1)
  202. NEL=VELCHE(/2)
  203. DO 400 IB=1,NEL
  204. DO 400 IGAU=1,NBPTEL
  205. XX=VELCHE(IGAU,IB)
  206. IF(IAB.EQ.1)XX=ABS(XX)
  207. *
  208. * TRI SELON LA VALEUR DE IMM
  209. *
  210. GO TO (21,21,23,24,25,26,27,28,29),IMM
  211. *
  212. CALL ERREUR(280)
  213. SEGSUP QUELCO
  214. IPMAIL=0
  215. RETURN
  216. *
  217. * MAXI OU MINI
  218. 21 IF(XX.EQ.XEXT) GO TO 403
  219. GO TO 400
  220. *
  221. * SUPE
  222. 23 IF(XX.GT.VALREF) GO TO 403
  223. GO TO 400
  224. *
  225. * EGSUPE
  226. 24 IF(XX.GE.VALREF) GO TO 403
  227. GO TO 400
  228. *
  229. * EGAL
  230. 25 IF(XX.EQ.VALREF) GO TO 403
  231. GO TO 400
  232. *
  233. * EGINFE
  234. 26 IF(XX.LE.VALREF) GO TO 403
  235. GO TO 400
  236. *
  237. * INFE
  238. 27 IF(XX.LT.VALREF) GO TO 403
  239. GO TO 400
  240. *
  241. * DIFF
  242. 28 IF(XX.NE.VALREF) GO TO 403
  243. GO TO 400
  244. *
  245. * COMP
  246. 29 IF((XX.GE.VALREF).AND.(XX.LE.VALRE2))GO TO 403
  247. GO TO 400
  248. *
  249. 403 CONTINUE
  250. NBELEM=NBELEM+1
  251. IF(NBELEM.GT.NBTEST) THEN
  252. NBTEST=NBELEM
  253. NBELEM = NBELEM*2
  254. SEGADJ MELEME
  255. NBELEM=NBTEST
  256. NBTEST= NUM(/2)
  257. ENDIF
  258. IF(MINTE.EQ.0)THEN
  259. NUM(1,NBELEM)=IPT1.NUM(IGAU,IB)
  260. ELSE
  261. CALL DOXE(XCOOR,IDIM,NBNN1,IPT1.NUM,IB,XE)
  262. XC=0.D0
  263. YC=0.D0
  264. ZC=0.D0
  265. DO 405 IE=1,NBNN1
  266. XC=XC+SHPTOT(1,IE,IGAU)*XE(1,IE)
  267. YC=YC+SHPTOT(1,IE,IGAU)*XE(2,IE)
  268. ZC=ZC+SHPTOT(1,IE,IGAU)*XE(3,IE)
  269. 405 CONTINUE
  270. NBPTS=XCOOR(/1)/(IDIM+1)
  271. NBPTS=NBPTS+1
  272. SEGADJ MCOORD
  273. XCOOR((NBPTS-1)*(IDIM+1)+1)=XC
  274. XCOOR((NBPTS-1)*(IDIM+1)+2)=YC
  275. IF(IDIM.EQ.3)
  276. 1 XCOOR((NBPTS-1)*(IDIM+1)+3)=ZC
  277. NUM(1,NBELEM)=NBPTS
  278. ENDIF
  279. *
  280. 400 CONTINUE
  281. 300 CONTINUE
  282. *
  283. ELSEIF(NNCO(ISOUS).NE.0)THEN
  284. DO 310 ICOMP=1,NCOMP
  285. IF(ICO(ISOUS,ICOMP).EQ.1)THEN
  286. MELVAL=IELVAL(ICOMP)
  287. SEGACT MELVAL
  288. NBPTEL=VELCHE(/1)
  289. NEL=VELCHE(/2)
  290. DO 410 IB=1,NEL
  291. DO 410 IGAU=1,NBPTEL
  292. XX=VELCHE(IGAU,IB)
  293. IF(IAB.EQ.1)XX=ABS(XX)
  294. *
  295. * TRI SELON LA VALEUR DE IMM
  296. *
  297. GO TO (31,31,33,34,35,36,37,38,39),IMM
  298. *
  299. CALL ERREUR(280)
  300. SEGSUP QUELCO
  301. IPMAIL=0
  302. RETURN
  303. *
  304. * MAXI OU MINI
  305. 31 IF(XX.EQ.XEXT) GO TO 413
  306. GO TO 410
  307. *
  308. * SUPE
  309. 33 IF(XX.GT.VALREF) GO TO 413
  310. GO TO 410
  311. *
  312. * EGSUPE
  313. 34 IF(XX.GE.VALREF) GO TO 413
  314. GO TO 410
  315. *
  316. * EGAL
  317. 35 IF(XX.EQ.VALREF) GO TO 413
  318. GO TO 410
  319. *
  320. * EGINFE
  321. 36 IF(XX.LE.VALREF) GO TO 413
  322. GO TO 410
  323. *
  324. * INFE
  325. 37 IF(XX.LT.VALREF) GO TO 413
  326. GO TO 410
  327. *
  328. * DIFF
  329. 38 IF(XX.NE.VALREF) GO TO 413
  330. GO TO 410
  331. *
  332. * COMP
  333. 39 IF((XX.GE.VALREF).AND.(XX.LE.VALRE2))GO TO 413
  334. GO TO 410
  335. *
  336. 413 CONTINUE
  337. NBELEM=NBELEM+1
  338. IF(NBELEM.GT.NBTEST) THEN
  339. NBTEST=NBELEM
  340. NBELEM = NBELEM*2
  341. SEGADJ MELEME
  342. NBELEM=NBTEST
  343. NBTEST= NUM(/2)
  344. ENDIF
  345. IF(MINTE.EQ.0)THEN
  346. NUM(1,NBELEM)=IPT1.NUM(IGAU,IB)
  347. ELSE
  348. CALL DOXE(XCOOR,IDIM,NBNN1,IPT1.NUM,IB,XE)
  349. XC=0.D0
  350. YC=0.D0
  351. ZC=0.D0
  352. DO 406 IE=1,NBNN1
  353. XC=XC+SHPTOT(1,IE,IGAU)*XE(1,IE)
  354. YC=YC+SHPTOT(1,IE,IGAU)*XE(2,IE)
  355. ZC=ZC+SHPTOT(1,IE,IGAU)*XE(3,IE)
  356. 406 CONTINUE
  357. NBPTS=XCOOR(/1)/(IDIM+1)
  358. NBPTS=NBPTS+1
  359. SEGADJ MCOORD
  360. XCOOR((NBPTS-1)*(IDIM+1)+1)=XC
  361. XCOOR((NBPTS-1)*(IDIM+1)+2)=YC
  362. IF(IDIM.EQ.3)
  363. 1 XCOOR((NBPTS-1)*(IDIM+1)+3)=ZC
  364. NUM(1,NBELEM)=NBPTS
  365. ENDIF
  366. 410 CONTINUE
  367. ENDIF
  368. 310 CONTINUE
  369. *
  370. ENDIF
  371. IF(MINTE.NE.0)SEGSUP MTRA
  372. *
  373. 600 CONTINUE
  374. SEGADJ MELEME
  375. IF(IPLIS.NE.0)SEGSUP QUELCO
  376. END
  377.  
  378.  
  379.  

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