Télécharger aviso.eso

Retour à la liste

Numérotation des lignes :

  1. C AVISO SOURCE PV 20/03/30 21:15:26 10567
  2. C
  3. SUBROUTINE AVISO(MELEME,MCHPOI,MCHAM,IPMO1,NISO1,
  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*8 CHOISI
  43. CHARACTER*4 CHOICO
  44. INTEGER NISO1
  45. C
  46. NISO = NISO1
  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. CALL VMISPO(IPMO1,MCHELM,MCARA,ICONV,MCHEL1,IRET)
  85. IF (IERR.NE.0) RETURN
  86. SEGACT MCHEL1
  87. DO 5 ISOUS=1,MCHEL1.IMACHE(/1)
  88. MCHAML=MCHEL1.ICHAML(ISOUS)
  89. SEGACT MCHAML*MOD
  90. NOMCHE(1)='VONMISES'
  91. 5 CONTINUE
  92. CALL FUSCHL(MCHEL1,MCHELM,MCHELO)
  93. MCHELM=MCHELO
  94. ENDIF
  95. ENDIF
  96.  
  97. * On cree le MELEME a tracer
  98. * On stocke les MELVAL dans LISREF (très astucieux)
  99. SEGACT MCHELM
  100. NBSOUS=IMACHE(/1)
  101. NBREF=NBSOUS
  102. NBNN=0
  103. NBELEM=0
  104. SEGINI MELEME
  105. ITYPEL=0
  106. DO ISOUS=1,NBSOUS
  107. LISOUS(ISOUS)=IMACHE(ISOUS)
  108. ENDDO
  109. nbinde=NBSOUS
  110. segini,indesou
  111. * kich : pour des modeles heterogenes (ex massif + poutre) pb de trace
  112. ksou = 0
  113. DO ISOUS=1,NBSOUS
  114. IF (INFCHE(ISOUS,2).EQ.1.AND.INFCHE(ISOUS,6).NE.1) THEN
  115. * pas un chamelem aux noeuds
  116. CALL ERREUR(609)
  117. RETURN
  118. ENDIF
  119. MCHAML=ICHAML(ISOUS)
  120. SEGACT MCHAML
  121.  
  122. * Constitution de la liste des noms de composantes COMPCH
  123. * kich : modif on crée une liste pour l ensemble du MCHELM
  124. * NCOMP=0
  125. CHOISI=' '
  126. IF (LCOMP.NE.0) CHOISI=COMPCH(LCOMP)
  127. IF (LCOMP.EQ.0) LCOMP=1
  128. DO 25 ICOMP=1,TYPCHE(/2)
  129. IF (TYPCHE(1).NE.'REAL*8') GOTO 25
  130. DO JCOMP=1,NCOMP
  131. IF (COMPCH(JCOMP).EQ.NOMCHE(ICOMP)) GOTO 25
  132. ENDDO
  133. * COMPCH dimensionné à 10 dans PRTRAC
  134. IF (NCOMP.EQ.10) GOTO 25
  135. NCOMP=NCOMP+1
  136. COMPCH(NCOMP)=NOMCHE(ICOMP)
  137. IF (CHOISI.EQ.' ') CHOISI=NOMCHE(ICOMP)
  138. 25 CONTINUE
  139. IF (NCOMP.EQ.0) THEN
  140. * Il faut spécifier un champ par élément avec une seule composante
  141. CALL ERREUR(320)
  142. RETURN
  143. ENDIF
  144. * provisoirement
  145. * DO JCOMP=1,NCOMP
  146. * kich : c est nomche qu il faut tester
  147. DO ICOMP=1,TYPCHE(/2)
  148. * IF (COMPCH(JCOMP).EQ.CHOISI) LISREF(ISOUS)=IELVAL(JCOMP)
  149. IF (CHOISI.EQ.NOMCHE(ICOMP)) THEN
  150. LISREF(ISOUS)=IELVAL(ICOMP)
  151. ksou = ksou + 1
  152. indesou(ksou ) = isous
  153. ENDIF
  154. ENDDO
  155. IF (IERR.NE.0) RETURN
  156. ENDDO
  157.  
  158. * verifie le meleme
  159. do jso = 1 ,ksou
  160. jsous = indesou(jso)
  161. lisous(jso) = lisous(jsous)
  162. lisref(jso) = lisref(jsous)
  163. if (lisref(jso).eq.0) call erreur(5)
  164. c write(6,*) 'verif', jso, lisous(jso),lisref(jso),lcomp
  165. enddo
  166. NBSOUS = ksou
  167. NBREF = NBSOUS
  168. segadj MELEME
  169. segsup,indesou
  170.  
  171. * Calcul des extrema
  172. DO ISOUS=1,NBSOUS
  173. MELVAL=LISREF(ISOUS)
  174. IF (MELVAL.NE.0) THEN
  175. SEGACT MELVAL
  176. DO INN=1,VELCHE(/1)
  177. DO IEL=1,VELCHE(/2)
  178. VCHMIN=MIN(VCHMIN,REAL(VELCHE(INN,IEL)))
  179. VCHMAX=MAX(VCHMAX,REAL(VELCHE(INN,IEL)))
  180. ENDDO
  181. ENDDO
  182. ENDIF
  183. ENDDO
  184. ENDIF
  185.  
  186. * Cas du CHPOINT
  187. * ==============
  188. IF (MCHAM.EQ.0) THEN
  189. * Récupération des valeurs du champ à tracer
  190. SEGACT MELEME
  191. SEGACT MCHPOI
  192. NSOUPO=IPCHP(/1)
  193. if(lcomp.eq.0) then
  194. ncomp=0
  195. do isoupo=1,nsoupo
  196. msoupo=ipchp(isoupo)
  197. segact msoupo
  198. do nbpp=1,nocomp(/2)
  199. do ncbb=1,ncomp
  200. if( compch(ncbb).eq.nocomp(nbpp)) go to 43
  201. enddo
  202. * COMPCH dimensionné à 10 dans PRTRAC
  203. IF (NCOMP.EQ.10) GOTO 43
  204. ncomp=ncomp+1
  205. compch(ncomp)=nocomp(nbpp)
  206. 43 continue
  207. enddo
  208. enddo
  209. lcomp=1
  210. if( (compch(1).eq.'LX '. or . compch (1).eq.'FLX ' )
  211. $ .and. ncomp.ge.2) lcomp=2
  212. endif
  213. choisi=compch(lcomp)
  214. DO ISOUPO=1,NSOUPO
  215. MSOUPO=IPCHP(ISOUPO)
  216. SEGACT MSOUPO
  217. MPOVAL=IPOVAL
  218. SEGACT MPOVAL
  219. IPT2=IGEOC
  220. SEGACT IPT2
  221. NCC=NOCOMP(/2)
  222. do ic=1,ncc
  223. if( choisi.eq.nocomp(ic)) go to 44
  224. enddo
  225. go to 45
  226. 44 continue
  227. DO IEL=1,IPT2.NUM(/2)
  228. IFOI=IPT2.NUM(1,IEL)
  229. VCPCHA(IFOI)=VPOCHA(IEL,IC)
  230. ENDDO
  231. 45 continue
  232. ENDDO
  233.  
  234. * Calcul des extrema
  235. IPT1=MELEME
  236. DO I=1,MAX(1,LISOUS(/1))
  237. IF (LISOUS(/1).NE.0) IPT1=LISOUS(I)
  238. SEGACT IPT1
  239. DO J=1,IPT1.NUM(/1)
  240. DO K=1,IPT1.NUM(/2)
  241. IPOIT=IPT1.NUM(J,K)
  242. VCHMIN=MIN(VCHMIN,REAL(VCPCHA(IPOIT)))
  243. VCHMAX=MAX(VCHMAX,REAL(VCPCHA(IPOIT)))
  244. ENDDO
  245. ENDDO
  246. ENDDO
  247. ENDIF
  248. C
  249. * Détermination de la liste d'isovaleurs
  250. * ======================================
  251. **-- par défaut
  252. IF (NISO.EQ.0) NISO=NCOUMA
  253. IF (ISOTYP.GT.0) NISO=NISO-1
  254.  
  255. *-- d'après un LISTREEL en entrée
  256. IF (MLREEL.EQ.0) CALL LIROBJ ('LISTREEL',MLREEL,0,IRETOU)
  257. IF (IERR.NE.0) RETURN
  258. IF (MLREEL.EQ.0) GOTO 9800
  259.  
  260. *PM On s'assure d'avoir une liste croissante
  261. SEGINI,MLREE1=MLREEL
  262. CALL ORDO01(MLREE1.PROG,MLREE1.PROG(/1),.TRUE.)
  263. SEGACT MLREEL
  264. *
  265. NISO=PROG(/1)
  266. IF (ISOTYP.GT.0) NISO=NISO+1
  267. *PM Limitation du nb d'isovaleurs au nombre de couleurs admissibles
  268. IF(NISO.GT.NCOUMA) THEN
  269. * write(IOIMP,*) 'ajustement à ',ncouma,' réels'
  270. JG=NCOUMA
  271. SEGADJ, MLREE1
  272. * on picore les valeurs parmi la liste entrée
  273. IDI = PROG(/1) / JG
  274. DO I=1,JG
  275. MLREE1.PROG(I)=PROG(1+((I-1)*IDI))
  276. ENDDO
  277. NISO=NCOUMA
  278. * CALL ERREUR(201)
  279. * GOTO 9099
  280. ENDIF
  281.  
  282. *PM PET=-1E30
  283. DO I=1,MLREE1.PROG(/1)
  284. VCHC(I)=MLREE1.PROG(I)
  285. *PM IF (VCHC(I).LE.PET) THEN
  286. *PM* Valeurs non croissantes dans la table
  287. *PM CALL ERREUR(211)
  288. *PM RETURN
  289. *PM ELSE
  290. *PM PET=MAX(PET,VCHC(I))
  291. *PM ENDIF
  292. ENDDO
  293. * Pas nécessaire ?
  294. *goo IF (ISOTYP.GT.0) VCHC(NISO)=VCHMAX
  295. SEGSUP MLREE1
  296. GOTO 9099
  297.  
  298. 9800 CONTINUE
  299.  
  300. *-- Progression arithmétique entre les extrêmes
  301. 9900 CONTINUE
  302. C gounand 2018/10/09
  303. C Si la valeur max est approx egale au min, on utilise un VCHMA2
  304. C legerement augmente par rapport à VCHMAX pour creer l'echelle de
  305. C valeurs et avoir le champ en bleu.
  306. C On ne modifie pas VCHMAX qui est la "vraie" valeur du max et qui
  307. C sert ailleurs
  308. *ancien IF (VCHMIN.EQ.VCHMAX) NISO=1
  309. *ancien if(abs((VCHMAX - VCHMIN)/VCHMIN).LT.1D-5) NISO = 1
  310. IF (EGAR4(VCHMIN,VCHMAX)) THEN
  311. VCHMA2=VCHMAX+(MAX(MAX(ABS(VCHMAX),ABS(VCHMIN))*XSZPRE,XSPETI)
  312. $ *NISO*2)
  313. ELSE
  314. VCHMA2=VCHMAX
  315. ENDIF
  316. C
  317. DO I=1,NISO+1
  318. VCHC(I)=VCHMIN+(I-1)*(VCHMA2-VCHMIN)/NISO
  319. ENDDO
  320. C On essaie de repérer s'il y a des NaNQ
  321. IF (.NOT.(VCHC(1).EQ.VCHC(1))) THEN
  322. NISO=1
  323. DO I=1,NISO+1
  324. VCHC(I)=VCHMIN+(I-1)*(VCHMA2-VCHMIN)/NISO
  325. ENDDO
  326. ENDIF
  327.  
  328. IT=0
  329. DO II=1,NISO
  330. IT=IT+1
  331. VCHC(IT)=(VCHC(II)+VCHC(II+1))/2
  332. ENDDO
  333. *gounand
  334. IF (ISOTYP.GT.0) NISO=NISO+1
  335. * Sortie
  336. * ======
  337. 9099 CONTINUE
  338.  
  339. END
  340.  
  341.  
  342.  
  343.  
  344.  

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