Télécharger aviso.eso

Retour à la liste

Numérotation des lignes :

  1. C AVISO SOURCE FD218221 14/07/11 21:15:01 8095
  2. C
  3. SUBROUTINE AVISO(MELEME,MCHPOI,MCHAM,IPMO1,
  4. > VCPCHA,VCHC,NISO,NCOUMA,VCHMIN,VCHMAX,MLREEL,MCARA,
  5. > NCOMP,LCOMP,COMPCH,choico)
  6. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  7. C
  8. C Préparation du tracé des isovaleurs d un objet
  9. c de type CHPOINT ou CHAMELEM
  10. C
  11. C Création
  12. C AOUT 85
  13. C
  14. C Modifications :
  15. C PM 09/11/2007 :
  16. C . ne conserve que le nb d'isovaleurs admissibles
  17. C si liste d'isovaleurs imposées
  18. C . accepte une liste d'isovaleurs non croissante
  19. C
  20. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  21. C
  22. IMPLICIT INTEGER(I-N)
  23. SEGMENT VCPCHA(XCOOR(/1)/(IDIM+1))
  24. -INC CCOPTIO
  25. -INC SMELEME
  26. -INC SMMODEL
  27. -INC SMCHPOI
  28. -INC SMCOORD
  29. -INC SMLREEL
  30. -INC SMCHAML
  31. -INC SMLMOTS
  32. REAL VCHC
  33. DIMENSION VCHC(*)
  34. c BP : indesou doit etre capable d'accueillir tous les nbsous modeles
  35. SEGMENT indesou(nbinde)
  36. * tableau des noms de composantes (chamelem)
  37. CHARACTER*(*) COMPCH(*)
  38. CHARACTER*8 CHOISI
  39. CHARACTER*4 CHOICO
  40. C
  41. * kich : modif ncomp etait deja initialise dans prtrac
  42. * NCOMP=0
  43.  
  44. DO I=1,VCPCHA(/1)
  45. VCPCHA(I)=0
  46. ENDDO
  47.  
  48. * Cas du MCHAML
  49. * =============
  50. IF (MCHAM.NE.0) THEN
  51. * Si ce sont des contraintes, on rajoute le Von Mises
  52. MCHELM=MCHAM
  53. SEGACT MCHELM
  54. IUN=1
  55. DO IU=1,ICHAML(/1)
  56. MCHAML=ICHAML(IU)
  57. SEGACT MCHAML
  58. IF(IELVAL(/1).NE.1) IUN=0
  59. ENDDO
  60. IF (TITCHE.EQ.'CONTRAINTES'.AND.IUN.NE.1) THEN
  61. C Petit traitement pour retirer JOI1 du calcul de VMIS
  62. MMODEL=IPMO1
  63. SEGACT,MMODEL
  64. N1=KMODEL(/1)
  65. SEGINI,MMODE1
  66. NN1=0
  67. DO 3 IMO=1,N1
  68. IMODEL=KMODEL(IMO)
  69. SEGACT,IMODEL
  70. IF(INFELE(13).EQ.75) GOTO 3
  71. NN1=NN1+1
  72. MMODE1.KMODEL(NN1)=IMODEL
  73. SEGDES,IMODEL
  74. 3 CONTINUE
  75. IF(NN1.EQ.0) THEN
  76. SEGSUP,MMODE1
  77. SEGDES,MMODEL
  78. ELSE
  79. N1=NN1
  80. SEGADJ,MMODE1
  81. SEGDES,MMODEL,MMODE1
  82. IPMO1=MMODE1
  83. CALL VMISPO(IPMO1,MCHELM,MCARA,ICONV,MCHEL1,IRET)
  84. IF (IERR.NE.0) RETURN
  85. SEGACT MCHEL1
  86. DO 5 ISOUS=1,MCHEL1.IMACHE(/1)
  87. MCHAML=MCHEL1.ICHAML(ISOUS)
  88. SEGACT MCHAML*MOD
  89. NOMCHE(1)='VONMISES'
  90. 5 CONTINUE
  91. CALL FUSCHL(MCHEL1,MCHELM,MCHELO)
  92. MCHELM=MCHELO
  93. ENDIF
  94. ENDIF
  95.  
  96. * On cree le MELEME a tracer
  97. * On stocke les MELVAL dans LISREF (très astucieux)
  98. SEGACT MCHELM
  99. NBSOUS=IMACHE(/1)
  100. NBREF=NBSOUS
  101. NBNN=0
  102. NBELEM=0
  103. SEGINI MELEME
  104. ITYPEL=0
  105. DO ISOUS=1,NBSOUS
  106. LISOUS(ISOUS)=IMACHE(ISOUS)
  107. ENDDO
  108. nbinde=NBSOUS
  109. segini,indesou
  110. * kich : pour des modeles heterogenes (ex massif + poutre) pb de trace
  111. ksou = 0
  112. DO ISOUS=1,NBSOUS
  113. IF (INFCHE(ISOUS,2).EQ.1.AND.INFCHE(ISOUS,6).NE.1) THEN
  114. * pas un chamelem aux noeuds
  115. CALL ERREUR(609)
  116. RETURN
  117. ENDIF
  118. MCHAML=ICHAML(ISOUS)
  119. SEGACT MCHAML
  120.  
  121. * Constitution de la liste des noms de composantes COMPCH
  122. * kich : modif on crée une liste pour l ensemble du MCHELM
  123. * NCOMP=0
  124. CHOISI=' '
  125. IF (LCOMP.NE.0) CHOISI=COMPCH(LCOMP)
  126. IF (LCOMP.EQ.0) LCOMP=1
  127. DO 25 ICOMP=1,TYPCHE(/2)
  128. IF (TYPCHE(1).NE.'REAL*8') GOTO 25
  129. DO JCOMP=1,NCOMP
  130. IF (COMPCH(JCOMP).EQ.NOMCHE(ICOMP)) GOTO 25
  131. ENDDO
  132. * COMPCH dimensionné à 10 dans PRTRAC
  133. IF (NCOMP.EQ.10) GOTO 25
  134. NCOMP=NCOMP+1
  135. COMPCH(NCOMP)=NOMCHE(ICOMP)
  136. IF (CHOISI.EQ.' ') CHOISI=NOMCHE(ICOMP)
  137. 25 CONTINUE
  138. IF (NCOMP.EQ.0) THEN
  139. * Il faut spécifier un champ par élément avec une seule composante
  140. CALL ERREUR(320)
  141. RETURN
  142. ENDIF
  143. * provisoirement
  144. * DO JCOMP=1,NCOMP
  145. * kich : c est nomche qu il faut tester
  146. DO ICOMP=1,TYPCHE(/2)
  147. * IF (COMPCH(JCOMP).EQ.CHOISI) LISREF(ISOUS)=IELVAL(JCOMP)
  148. IF (CHOISI.EQ.NOMCHE(ICOMP)) THEN
  149. LISREF(ISOUS)=IELVAL(ICOMP)
  150. ksou = ksou + 1
  151. indesou(ksou ) = isous
  152. ENDIF
  153. ENDDO
  154. IF (IERR.NE.0) RETURN
  155. SEGDES MCHAML
  156. ENDDO
  157. SEGDES MCHELM
  158.  
  159. * verifie le meleme
  160. do jso = 1 ,ksou
  161. jsous = indesou(jso)
  162. lisous(jso) = lisous(jsous)
  163. lisref(jso) = lisref(jsous)
  164. if (lisref(jso).eq.0) call erreur(5)
  165. c write(6,*) 'verif', jso, lisous(jso),lisref(jso),lcomp
  166. enddo
  167. NBSOUS = ksou
  168. NBREF = NBSOUS
  169. segadj MELEME
  170. segsup,indesou
  171.  
  172. * Calcul des extrema
  173. DO ISOUS=1,NBSOUS
  174. MELVAL=LISREF(ISOUS)
  175. IF (MELVAL.NE.0) THEN
  176. SEGACT MELVAL
  177. DO INN=1,VELCHE(/1)
  178. DO IEL=1,VELCHE(/2)
  179. VCHMIN=MIN(VCHMIN,REAL(VELCHE(INN,IEL)))
  180. VCHMAX=MAX(VCHMAX,REAL(VELCHE(INN,IEL)))
  181. ENDDO
  182. ENDDO
  183. ENDIF
  184. ENDDO
  185. ENDIF
  186.  
  187. * Cas du CHPOINT
  188. * ==============
  189. IF (MCHAM.EQ.0) THEN
  190. * Récupération des valeurs du champ à tracer
  191. SEGACT MELEME
  192. SEGACT MCHPOI
  193. NSOUPO=IPCHP(/1)
  194. if(lcomp.eq.0) then
  195. ncomp=0
  196. do isoupo=1,nsoupo
  197. msoupo=ipchp(isoupo)
  198. segact msoupo
  199. do nbpp=1,nocomp(/2)
  200. do ncbb=1,ncomp
  201. if( compch(ncbb).eq.nocomp(nbpp)) go to 43
  202. enddo
  203. * COMPCH dimensionné à 10 dans PRTRAC
  204. IF (NCOMP.EQ.10) GOTO 43
  205. ncomp=ncomp+1
  206. compch(ncomp)=nocomp(nbpp)
  207. 43 continue
  208. enddo
  209. enddo
  210. lcomp=1
  211. if( (compch(1).eq.'LX '. or . compch (1).eq.'FLX ' )
  212. $ .and. ncomp.ge.2) lcomp=2
  213. endif
  214. choisi=compch(lcomp)
  215. DO ISOUPO=1,NSOUPO
  216. MSOUPO=IPCHP(ISOUPO)
  217. SEGACT MSOUPO
  218. MPOVAL=IPOVAL
  219. SEGACT MPOVAL
  220. IPT2=IGEOC
  221. SEGACT IPT2
  222. NCC=NOCOMP(/2)
  223. do ic=1,ncc
  224. if( choisi.eq.nocomp(ic)) go to 44
  225. enddo
  226. go to 45
  227. 44 continue
  228. DO IEL=1,IPT2.NUM(/2)
  229. IFOI=IPT2.NUM(1,IEL)
  230. VCPCHA(IFOI)=VPOCHA(IEL,IC)
  231. ENDDO
  232. 45 continue
  233. SEGDES IPT2,MPOVAL,MSOUPO
  234. ENDDO
  235.  
  236. * Calcul des extrema
  237. IPT1=MELEME
  238. DO I=1,MAX(1,LISOUS(/1))
  239. IF (LISOUS(/1).NE.0) IPT1=LISOUS(I)
  240. SEGACT IPT1
  241. DO J=1,IPT1.NUM(/1)
  242. DO K=1,IPT1.NUM(/2)
  243. IPOIT=IPT1.NUM(J,K)
  244. VCHMIN=MIN(VCHMIN,REAL(VCPCHA(IPOIT)))
  245. VCHMAX=MAX(VCHMAX,REAL(VCPCHA(IPOIT)))
  246. ENDDO
  247. ENDDO
  248. IF (LISOUS(/1).NE.0) SEGDES IPT1
  249. ENDDO
  250. SEGDES MELEME
  251. SEGDES MCHPOI
  252. ENDIF
  253. C
  254. * Détermination de la liste d'isovaleurs
  255. * ======================================
  256. **-- par défaut
  257. NISO=NCOUMA
  258. IF (ISOTYP.GT.0) NISO=NISO-1
  259. *-- d'après un LISTREEL en entrée
  260. IF (MLREEL.EQ.0) CALL LIROBJ ('LISTREEL',MLREEL,0,IRETOU)
  261. IF (MLREEL.EQ.0) GOTO 9800
  262.  
  263. *PM On s'assure d'avoir une liste croissante
  264. SEGINI,MLREE1=MLREEL
  265. CALL ORDO01(MLREE1.PROG,MLREE1.PROG(/1),.TRUE.)
  266. SEGACT MLREEL
  267. *
  268. NISO=PROG(/1)
  269. IF (ISOTYP.GT.0) NISO=NISO+1
  270. *PM Limitation du nb d'isovaleurs au nombre de couleurs admissibles
  271. IF(NISO.GT.NCOUMA) THEN
  272. * write(IOIMP,*) 'ajustement à ',ncouma,' réels'
  273. JG=NCOUMA
  274. SEGADJ, MLREE1
  275. * on picore les valeurs parmi la liste entrée
  276. IDI = PROG(/1) / JG
  277. DO I=1,JG
  278. MLREE1.PROG(I)=PROG(1+((I-1)*IDI))
  279. ENDDO
  280. NISO=NCOUMA
  281. * CALL ERREUR(201)
  282. * GOTO 9099
  283. ENDIF
  284. SEGDES, MLREEL
  285.  
  286. *PM PET=-1E30
  287. DO I=1,MLREE1.PROG(/1)
  288. VCHC(I)=MLREE1.PROG(I)
  289. *PM IF (VCHC(I).LE.PET) THEN
  290. *PM* Valeurs non croissantes dans la table
  291. *PM CALL ERREUR(211)
  292. *PM RETURN
  293. *PM ELSE
  294. *PM PET=MAX(PET,VCHC(I))
  295. *PM ENDIF
  296. ENDDO
  297. * Pas nécessaire ?
  298. *goo IF (ISOTYP.GT.0) VCHC(NISO)=VCHMAX
  299. SEGSUP MLREE1
  300. GOTO 9099
  301.  
  302. *-- d'après un ENTIER en entrée
  303. 9800 CALL LIRENT(NIZO,0,IRETOU)
  304. IF (IRETOU.NE.0) NISO=MIN(NIZO,NISO)
  305. NISO=MAX(1,NISO)
  306.  
  307. *-- Progression arithmétique entre les extrêmes
  308. 9900 CONTINUE
  309. C Si la valeur max est egal au min on ne prend qu'une couleur
  310. IF (VCHMIN.EQ.VCHMAX) NISO=1
  311. C
  312. DO I=1,NISO+1
  313. VCHC(I)=VCHMIN+(I-1)*(VCHMAX-VCHMIN)/NISO
  314. ENDDO
  315. C On essaie de repérer s'il y a des NaNQ
  316. IF (.NOT.(VCHC(1).EQ.VCHC(1))) THEN
  317. NISO=1
  318. DO I=1,NISO+1
  319. VCHC(I)=VCHMIN+(I-1)*(VCHMAX-VCHMIN)/NISO
  320. ENDDO
  321. ENDIF
  322.  
  323. IT=0
  324. DO II=1,NISO
  325. IT=IT+1
  326. VCHC(IT)=(VCHC(II)+VCHC(II+1))/2
  327. ENDDO
  328. *gounand
  329. IF (ISOTYP.GT.0) NISO=NISO+1
  330. * Sortie
  331. * ======
  332. 9099 CONTINUE
  333. SEGDES MELEME
  334.  
  335. RETURN
  336. END
  337.  
  338.  
  339.  
  340.  
  341.  
  342.  
  343.  
  344.  
  345.  
  346.  
  347.  
  348.  
  349.  
  350.  
  351.  
  352.  
  353.  
  354.  
  355.  
  356.  
  357.  
  358.  
  359.  
  360.  
  361.  
  362.  

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