Télécharger expchp.eso

Retour à la liste

Numérotation des lignes :

  1. C EXPCHP SOURCE CHAT 05/01/12 23:51:20 5004
  2. SUBROUTINE EXPCHP(IPCHPO,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/POINT
  6. *
  7. ************************************************************************
  8. * ENTREES :
  9. *
  10. * IPCHPO =POINTEUR SUR UN CHPOINT
  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 OU AUTRES
  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 SMCHPOI
  30. -INC SMELEME
  31. -INC SMCOORD
  32. -INC SMLMOTS
  33. *
  34. SEGMENT QUELCO
  35. INTEGER ICO(NSOUS,NCOMX),NNCO(NSOUS)
  36. ENDSEGMENT
  37. * SEGMENT ICPR(xcoor(/1)/(IDIM+1))
  38. CHARACTER*4 MOCOMP
  39. DIMENSION XE(3,1)
  40. *
  41. * INITIALISATIONS
  42. *
  43. IF(IAB.EQ.0)THEN
  44. IF(IMM.EQ.1)THEN
  45. XEXT=-1.D35
  46. ELSE
  47. XEXT=1.D35
  48. ENDIF
  49. ELSE
  50. IF(IMM.EQ.1)THEN
  51. XEXT=0.D0
  52. ELSE
  53. XEXT=1.D35
  54. ENDIF
  55. ENDIF
  56. *
  57. IF(IPLIS.NE.0)THEN
  58. MLMOTS=IPLIS
  59. SEGACT MLMOTS
  60. NC=MOTS(/2)
  61. ENDIF
  62. *
  63. * ON RECUPERE LE CHPOINT
  64. *
  65. MCHPOI=IPCHPO
  66. SEGACT MCHPOI
  67. NSOUS = IPCHP(/1)
  68.  
  69. *
  70. * ON CHERCHE LE NOMBRE MAXIMAL DE COMPOSANTES
  71. *
  72. NCOMX = 0
  73. DO 10 ISOUS=1,NSOUS
  74. MSOUPO=IPCHP(ISOUS)
  75. SEGACT MSOUPO
  76. NCOMX=MAX(NCOMX,NOCOMP(/2))
  77. 10 CONTINUE
  78. *
  79. IF(IPLIS.NE.0)SEGINI QUELCO
  80.  
  81. *
  82. * BOUCLE SUR LES SOUS-ZONES POUR TROUVER LE MAXI OU LE MINI
  83. * SI IMM = 1 OU 2
  84. *
  85. DO 500 ISOUS=1,NSOUS
  86. *
  87. MSOUPO=IPCHP(ISOUS)
  88. NCOMP=NOCOMP(/2)
  89. IF(IPLIS.NE.0)THEN
  90. NCO=0
  91. DO 20 ICOMP=1,NCOMP
  92. MOCOMP=NOCOMP(ICOMP)
  93. CALL PLACE(MOTS,NC,IX,MOCOMP)
  94. IF(IAV.EQ.1)THEN
  95. IF(IX.NE.0)THEN
  96. ICO(ISOUS,ICOMP)=1
  97. NCO=NCO+1
  98. ELSE
  99. ICO(ISOUS,ICOMP)=0
  100. ENDIF
  101. ELSE
  102. IF(IX.EQ.0)THEN
  103. ICO(ISOUS,ICOMP)=1
  104. NCO=NCO+1
  105. ELSE
  106. ICO(ISOUS,ICOMP)=0
  107. ENDIF
  108. ENDIF
  109. 20 CONTINUE
  110. NNCO(ISOUS)=NCO
  111. ENDIF
  112. *
  113. IF(IMM.LE.2) THEN
  114. *
  115. IF(IPLIS.EQ.0)THEN
  116. MPOVAL=IPOVAL
  117. SEGACT MPOVAL
  118. N=VPOCHA(/1)
  119. DO 100 ICOMP=1,NCOMP
  120. DO 100 IB=1,N
  121. XX=VPOCHA(IB,ICOMP)
  122. IF(IAB.EQ.1) XX=ABS(XX)
  123. IF(IMM.EQ.1)THEN
  124. XEXT=MAX(XX,XEXT)
  125. ELSE
  126. XEXT=MIN(XX,XEXT)
  127. ENDIF
  128. 100 CONTINUE
  129. SEGDES MPOVAL
  130. ELSEIF(NCO.NE.0)THEN
  131. MPOVAL=IPOVAL
  132. SEGACT MPOVAL
  133. N=VPOCHA(/1)
  134. DO 110 ICOMP=1,NCOMP
  135. IF(ICO(ISOUS,ICOMP).EQ.1)THEN
  136. DO 210 IB=1,N
  137. XX=VPOCHA(IB,ICOMP)
  138. IF(IAB.EQ.1) XX=ABS(XX)
  139. IF(IMM.EQ.1)THEN
  140. XEXT=MAX(XX,XEXT)
  141. ELSE
  142. XEXT=MIN(XX,XEXT)
  143. ENDIF
  144. 210 CONTINUE
  145. ENDIF
  146. 110 CONTINUE
  147. SEGDES MPOVAL
  148. ENDIF
  149. ENDIF
  150. *
  151. SEGDES MSOUPO
  152. 500 CONTINUE
  153. IF(IPLIS.NE.0)THEN
  154. SEGDES MLMOTS
  155. NZERO=0
  156. DO 510 ISOUS=1,NSOUS
  157. IF(NNCO(ISOUS).EQ.0)NZERO=NZERO+1
  158. 510 CONTINUE
  159. IF(NZERO.EQ.NSOUS)THEN
  160. CALL ERREUR(280)
  161. SEGDES MCHPOI
  162. SEGSUP QUELCO
  163. IPMAIL=0
  164. RETURN
  165. ENDIF
  166. ENDIF
  167. *
  168. * CREATION DE L'OBJET MAILLAGE CONTENANT LES POINTS SUPPORTS
  169. *
  170. NBNN=1
  171. NBELEM=XCOOR(/1)/(IDIM+1)
  172. NBSOUS=0
  173. NBREF=0
  174. SEGINI MELEME
  175. IPMAIL=MELEME
  176. ITYPEL=1
  177. NBELEM=0
  178. *
  179. * DEUXIEME BOUCLE SUR LES SOUS-ZONES POUR TROUVER LES POINTS SUPPORTS
  180. *
  181. DO 600 ISOUS=1,NSOUS
  182. *
  183. MSOUPO=IPCHP(ISOUS)
  184. SEGACT MSOUPO
  185. NCOMP=NOCOMP(/2)
  186. IPT1=IGEOC
  187. SEGACT IPT1
  188. IF(IPLIS.EQ.0)THEN
  189. MPOVAL=IPOVAL
  190. SEGACT MPOVAL
  191. N=VPOCHA(/1)
  192. DO 300 ICOMP=1,NCOMP
  193. DO 300 IB=1,N
  194. XX=VPOCHA(IB,ICOMP)
  195. IF(IAB.EQ.1)XX=ABS(XX)
  196. *
  197. * TRI SELON LA VALEUR DE IMM
  198. *
  199. GO TO (21,21,23,24,25,26,27,28,29),IMM
  200. *
  201. CALL ERREUR(280)
  202. SEGDES MCHPOI
  203. SEGSUP QUELCO
  204. IPMAIL=0
  205. RETURN
  206. *
  207. * MAXI OU MINI
  208. 21 IF(XX.EQ.XEXT) GO TO 303
  209. GO TO 300
  210. *
  211. * SUPE
  212. 23 IF(XX.GT.VALREF) GO TO 303
  213. GO TO 300
  214. *
  215. * EGSUPE
  216. 24 IF(XX.GE.VALREF) GO TO 303
  217. GO TO 300
  218. *
  219. * EGAL
  220. 25 IF(XX.EQ.VALREF) GO TO 303
  221. GO TO 300
  222. *
  223. * EGINFE
  224. 26 IF(XX.LE.VALREF) GO TO 303
  225. GO TO 300
  226. *
  227. * INFE
  228. 27 IF(XX.LT.VALREF) GO TO 303
  229. GO TO 300
  230. *
  231. * DIFF
  232. 28 IF(XX.NE.VALREF) GO TO 303
  233. GO TO 300
  234. *
  235. * COMP
  236. 29 IF((XX.GE.VALREF).AND.(XX.LE.VALRE2)) GO TO 303
  237. GO TO 300
  238. *
  239. 303 CONTINUE
  240. NBELEM=NBELEM+1
  241. * SEGADJ MELEME
  242. NUM(1,NBELEM)=IPT1.NUM(1,IB)
  243. *
  244. 300 CONTINUE
  245. SEGDES MPOVAL
  246. *
  247. ELSEIF(NNCO(ISOUS).NE.0)THEN
  248. MPOVAL=IPOVAL
  249. SEGACT MPOVAL
  250. N=VPOCHA(/1)
  251. DO 310 ICOMP=1,NCOMP
  252. IF(ICO(ISOUS,ICOMP).EQ.1)THEN
  253. DO 410 IB=1,N
  254. XX=VPOCHA(IB,ICOMP)
  255. IF(IAB.EQ.1)XX=ABS(XX)
  256. *
  257. *
  258. * TRI SELON LA VALEUR DE IMM
  259. *
  260. GO TO (31,31,33,34,35,36,37,38,39),IMM
  261. *
  262. CALL ERREUR(280)
  263. SEGDES MCHPOI
  264. SEGSUP QUELCO
  265. IPMAIL=0
  266. RETURN
  267. *
  268. * MAXI OU MINI
  269. 31 IF(XX.EQ.XEXT) GO TO 413
  270. GO TO 410
  271. *
  272. * SUPE
  273. 33 IF(XX.GT.VALREF) GO TO 413
  274. GO TO 410
  275. *
  276. * EGSUPE
  277. 34 IF(XX.GE.VALREF) GO TO 413
  278. GO TO 410
  279. *
  280. * EGAL
  281. 35 IF(XX.EQ.VALREF) GO TO 413
  282. GO TO 410
  283. *
  284. * EGINFE
  285. 36 IF(XX.LE.VALREF) GO TO 413
  286. GO TO 410
  287. *
  288. * INFE
  289. 37 IF(XX.LT.VALREF) GO TO 413
  290. GO TO 410
  291. *
  292. * DIFF
  293. 38 IF(XX.NE.VALREF) GO TO 413
  294. GO TO 410
  295. *
  296. * COMP
  297. 39 IF((XX.GE.VALREF).AND.(XX.LE.VALRE2)) GO TO 413
  298. GO TO 410
  299. *
  300. 413 CONTINUE
  301. NBELEM=NBELEM+1
  302. * SEGADJ MELEME
  303. NUM(1,NBELEM)=IPT1.NUM(1,IB)
  304. 410 CONTINUE
  305. *
  306. ENDIF
  307. 310 CONTINUE
  308. SEGDES MPOVAL
  309. ENDIF
  310. SEGDES MSOUPO,IPT1
  311. *
  312. 600 CONTINUE
  313. SEGADJ MELEME
  314. SEGDES MCHPOI,MELEME
  315. IF(IPLIS.NE.0)SEGSUP QUELCO
  316. RETURN
  317. END
  318.  
  319.  
  320.  

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