Télécharger aviso.eso

Retour à la liste

Numérotation des lignes :

aviso
  1. C AVISO SOURCE PASCAL 22/05/10 21:15:01 11366
  2. C
  3. SUBROUTINE AVISO(MELEME,MCHPOI,MCHAM,IPMO1,NISOD,
  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(nbpts)
  24. -INC CCREEL
  25.  
  26. -INC PPARAM
  27. -INC CCOPTIO
  28. -INC SMELEME
  29. -INC SMMODEL
  30. -INC SMCHPOI
  31. -INC SMCOORD
  32. -INC SMLREEL
  33. -INC SMCHAML
  34. -INC SMLMOTS
  35. logical egar4
  36. REAL VCHC
  37. DIMENSION VCHC(*)
  38. c BP : indesou doit etre capable d'accueillir tous les nbsous modeles
  39. SEGMENT indesou(nbinde)
  40. * tableau des noms de composantes (chamelem)
  41. CHARACTER*(*) COMPCH(*)
  42. CHARACTER*(LOCOMP) CHOISI
  43. INTEGER CHOICO
  44. INTEGER NISOD
  45. C
  46. NISO = NISOD
  47.  
  48. DO I=1,VCPCHA(/1)
  49. VCPCHA(I)=0
  50. ENDDO
  51.  
  52. * Cas du MCHAML
  53. * =============
  54. IF (MCHAM.NE.0) THEN
  55. * Si ce sont des contraintes, on rajoute le Von Mises
  56. MCHELM=MCHAM
  57. SEGACT MCHELM
  58. IUN=1
  59. DO IU=1,ICHAML(/1)
  60. MCHAML=ICHAML(IU)
  61. SEGACT MCHAML
  62. IF(IELVAL(/1).NE.1) IUN=0
  63. ENDDO
  64. IF (TITCHE.EQ.'CONTRAINTES'.AND.IUN.NE.1) THEN
  65. C Petit traitement pour retirer JOI1 du calcul de VMIS
  66. MMODEL=IPMO1
  67. SEGACT,MMODEL
  68. N1=KMODEL(/1)
  69. SEGINI,MMODE1
  70. NN1=0
  71. DO 3 IMO=1,N1
  72. IMODEL=KMODEL(IMO)
  73. SEGACT,IMODEL
  74. IF(INFELE(13).EQ.75) GOTO 3
  75. NN1=NN1+1
  76. MMODE1.KMODEL(NN1)=IMODEL
  77. 3 CONTINUE
  78. IF(NN1.EQ.0) THEN
  79. SEGSUP,MMODE1
  80. ELSE
  81. N1=NN1
  82. SEGADJ,MMODE1
  83. IPMO1=MMODE1
  84. isouc=1
  85. CALL VMISPO(IPMO1,MCHELM,MCARA,ICONV,MCHEL1,IRET,isouc)
  86. IF (IERR.NE.0) RETURN
  87. SEGACT MCHEL1
  88. DO 5 ISOUS=1,MCHEL1.IMACHE(/1)
  89. MCHAML=MCHEL1.ICHAML(ISOUS)
  90. SEGACT MCHAML*MOD
  91. NOMCHE(1)='VONMISES'
  92. 5 CONTINUE
  93. CALL FUSCHL(MCHEL1,MCHELM,MCHELO)
  94. MCHELM=MCHELO
  95. ENDIF
  96. ENDIF
  97.  
  98. * On cree le MELEME a tracer
  99. * On stocke les MELVAL dans LISREF (très astucieux)
  100. SEGACT MCHELM
  101. NBSOUS=IMACHE(/1)
  102. NBREF=NBSOUS
  103. NBNN=0
  104. NBELEM=0
  105. SEGINI MELEME
  106. ITYPEL=0
  107. DO ISOUS=1,NBSOUS
  108. LISOUS(ISOUS)=IMACHE(ISOUS)
  109. ENDDO
  110. nbinde=NBSOUS
  111. segini,indesou
  112. * kich : pour des modeles heterogenes (ex massif + poutre) pb de trace
  113. ksou = 0
  114. DO ISOUS=1,NBSOUS
  115. IF (INFCHE(ISOUS,2).EQ.1.AND.INFCHE(ISOUS,6).NE.1) THEN
  116. * pas un chamelem aux noeuds
  117. CALL ERREUR(609)
  118. RETURN
  119. ENDIF
  120. MCHAML=ICHAML(ISOUS)
  121. SEGACT MCHAML
  122.  
  123. * Constitution de la liste des noms de composantes COMPCH
  124. * kich : modif on crée une liste pour l ensemble du MCHELM
  125. * NCOMP=0
  126. CHOISI=' '
  127. IF (LCOMP.NE.0) CHOISI=COMPCH(LCOMP)
  128. IF (LCOMP.EQ.0) LCOMP=1
  129. DO 25 ICOMP=1,TYPCHE(/2)
  130. IF (TYPCHE(1).NE.'REAL*8') GOTO 25
  131. DO JCOMP=1,NCOMP
  132. IF (COMPCH(JCOMP).EQ.NOMCHE(ICOMP)) GOTO 25
  133. ENDDO
  134. * COMPCH dimensionné à 10 dans PRTRAC
  135. IF (NCOMP.EQ.10) GOTO 25
  136. NCOMP=NCOMP+1
  137. COMPCH(NCOMP)=NOMCHE(ICOMP)
  138. IF (CHOISI.EQ.' ') CHOISI=NOMCHE(ICOMP)
  139. 25 CONTINUE
  140. IF (NCOMP.EQ.0) THEN
  141. * Il faut spécifier un champ par élément avec une seule composante
  142. CALL ERREUR(320)
  143. RETURN
  144. ENDIF
  145. * provisoirement
  146. * DO JCOMP=1,NCOMP
  147. * kich : c est nomche qu il faut tester
  148. DO ICOMP=1,TYPCHE(/2)
  149. * IF (COMPCH(JCOMP).EQ.CHOISI) LISREF(ISOUS)=IELVAL(JCOMP)
  150. IF (CHOISI.EQ.NOMCHE(ICOMP)) THEN
  151. LISREF(ISOUS)=IELVAL(ICOMP)
  152. ksou = ksou + 1
  153. indesou(ksou ) = isous
  154. ENDIF
  155. ENDDO
  156. IF (IERR.NE.0) RETURN
  157. ENDDO
  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. ENDDO
  234.  
  235. * Calcul des extrema
  236. IPT1=MELEME
  237. DO I=1,MAX(1,LISOUS(/1))
  238. IF (LISOUS(/1).NE.0) IPT1=LISOUS(I)
  239. SEGACT IPT1
  240. DO J=1,IPT1.NUM(/1)
  241. DO K=1,IPT1.NUM(/2)
  242. IPOIT=IPT1.NUM(J,K)
  243. VCHMIN=MIN(VCHMIN,REAL(VCPCHA(IPOIT)))
  244. VCHMAX=MAX(VCHMAX,REAL(VCPCHA(IPOIT)))
  245. ENDDO
  246. ENDDO
  247. ENDDO
  248. ENDIF
  249. C
  250. * Détermination de la liste d'isovaleurs
  251. * ======================================
  252. **-- par défaut
  253. IF (ISOTYP.EQ.0) THEN
  254. NISOMA=NCOUMA
  255. ELSE
  256. NISOMA=NCOUMA-1
  257. ENDIF
  258. IF (NISO.LE.0.OR.NISO.GT.NISOMA) NISO=NISOMA
  259. *-- d'après un LISTREEL en entrée
  260. IF (MLREEL.EQ.0) CALL LIROBJ ('LISTREEL',MLREEL,0,IRETOU)
  261. IF (IERR.NE.0) RETURN
  262. IF (MLREEL.EQ.0) GOTO 9800
  263.  
  264. *PM On s'assure d'avoir une liste croissante
  265. SEGINI,MLREE1=MLREEL
  266. CALL ORDO01(MLREE1.PROG,MLREE1.PROG(/1),.TRUE.)
  267. SEGACT MLREEL
  268. *
  269. NISO=PROG(/1)
  270. IF (ISOTYP.GT.0) NISO=NISO+1
  271. IF (NISO.LE.0) NISO=NISOMA
  272. *PM Limitation du nb d'isovaleurs au nombre de couleurs admissibles
  273. IF(NISO.GT.NISOMA) THEN
  274. * write(IOIMP,*) 'ajustement à ',nisoma,' réels'
  275. JG=NISOMA
  276. SEGADJ, MLREE1
  277. * on picore les valeurs parmi la liste entrée
  278. IDI = PROG(/1) / JG
  279. DO I=1,JG
  280. MLREE1.PROG(I)=PROG(1+((I-1)*IDI))
  281. ENDDO
  282. NISO=NISOMA
  283. * CALL ERREUR(201)
  284. * GOTO 9099
  285. ENDIF
  286.  
  287. *PM PET=-1E30
  288. DO I=1,MLREE1.PROG(/1)
  289. VCHC(I)=MLREE1.PROG(I)
  290. *PM IF (VCHC(I).LE.PET) THEN
  291. *PM* Valeurs non croissantes dans la table
  292. *PM CALL ERREUR(211)
  293. *PM RETURN
  294. *PM ELSE
  295. *PM PET=MAX(PET,VCHC(I))
  296. *PM ENDIF
  297. ENDDO
  298. * Pas nécessaire ?
  299. *goo IF (ISOTYP.GT.0) VCHC(NISO)=VCHMAX
  300. SEGSUP MLREE1
  301. GOTO 9099
  302.  
  303. 9800 CONTINUE
  304.  
  305. *-- Progression arithmétique entre les extrêmes
  306. 9900 CONTINUE
  307. C gounand 2018/10/09
  308. C Si la valeur max est approx egale au min, on utilise un VCHMA2
  309. C legerement augmente par rapport à VCHMAX pour creer l'echelle de
  310. C valeurs et avoir le champ en bleu.
  311. C On ne modifie pas VCHMAX qui est la "vraie" valeur du max et qui
  312. C sert ailleurs
  313. *ancien IF (VCHMIN.EQ.VCHMAX) NISO=1
  314. *ancien if(abs((VCHMAX - VCHMIN)/VCHMIN).LT.1D-5) NISO = 1
  315. IF (EGAR4(VCHMIN,VCHMAX)) THEN
  316. VCHMA2=VCHMAX+(MAX(MAX(ABS(VCHMAX),ABS(VCHMIN))*XSZPRE,XSPETI)
  317. $ *NISO*2)
  318. ELSE
  319. VCHMA2=VCHMAX
  320. ENDIF
  321. C
  322. DO I=1,NISO+1
  323. VCHC(I)=VCHMIN+I*(VCHMA2-VCHMIN)/(NISO+1)
  324. ENDDO
  325. C On essaie de repérer s'il y a des NaNQ
  326. IF (.NOT.(VCHC(1).EQ.VCHC(1))) THEN
  327. NISO=1
  328. VCHC(1)=VCHMIN
  329. VCHC(2)=VCHMA2
  330. ENDIF
  331.  
  332. * gounand : sorti de aviso.eso NISO est en fait le nombre de
  333. * couleurs demandees plutôt que le nombre d'isovaleurs demandees
  334. IF (ISOTYP.GT.0) NISO=NISO+1
  335. * Sortie
  336. * ======
  337. 9099 CONTINUE
  338.  
  339. END
  340.  
  341.  
  342.  
  343.  
  344.  
  345.  
  346.  

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