Télécharger aviso.eso

Retour à la liste

Numérotation des lignes :

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

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