Télécharger isoint.eso

Retour à la liste

Numérotation des lignes :

  1. C ISOINT SOURCE BP208322 16/11/18 21:17:53 9177
  2. C VISUALISATION INTERACTIVE D'ISOVALEUR
  3. C
  4. SUBROUTINE ISOINT(VCPCHA,MELEME,ICPR,XPROJ,IVU,PAS,XMI,YMI,X1,Y1,
  5. > mcham)
  6. IMPLICIT INTEGER(I-N)
  7. -INC SMELEME
  8. -INC CCOPTIO
  9. -INC CCGEOME
  10. -INC SMCHAML
  11. SEGMENT XPROJ(3,0)
  12. SEGMENT VCPCHA(0)
  13. SEGMENT IVU(0)
  14. SEGMENT ICPR(0)
  15. CHARACTER*19 TEXT2
  16. SEGACT VCPCHA,IVU,ICPR,XPROJ
  17. 400 CONTINUE
  18. CALL TRMESS('POINTEZ LE LIEU OU OBTENIR LA VALEUR DU CHAMP')
  19. CALL TRDIG(XP,YP,INCLE)
  20. XP=(XP-X1)/PAS+XMI
  21. YP=(YP-Y1)/PAS+YMI
  22. IPT1=MELEME
  23. SEGACT IPT1
  24. DO 220 IO=1,MAX(1,LISOUS(/1))
  25. IF (LISOUS(/1).NE.0) THEN
  26.  
  27. IPT1=LISOUS(IO)
  28. if (mcham.ne.0) then
  29. melval=lisref(io)
  30. segact melval
  31. lval=velche(/1)
  32. endif
  33. SEGACT IPT1
  34. ENDIF
  35. NBNN=IPT1.NUM(/1)
  36. IF (KSURF(IPT1.ITYPEL).NE.0) GOTO 30
  37. * C'EST UNE LIGNE
  38. DO 20 IEL=1,IPT1.NUM(/2)
  39. do 21 iafa=1,nbnn-1
  40. ibfa=iafa+1
  41. IPA=IPT1.NUM(iafa,iel)
  42. IA=ICPR(IPA)
  43. IPB=IPT1.NUM(ibfa,iel)
  44. IB=ICPR(IPB)
  45. IF (IVU(IA).LE.0) GOTO 20
  46. IF (IVU(IB).LE.0) GOTO 20
  47. XA=XPROJ(1,IA)
  48. YA=XPROJ(2,IA)
  49. XB=XPROJ(1,IB)
  50. YB=XPROJ(2,IB)
  51. SCA=(XP-XA)*(XP-XB)+(YP-YA)*(YP-YB)
  52. xlong=(xb-xa)**2+(yb-ya)**2
  53. IF (SCA.LE.-0.9*xlong) GOTO 95
  54. 21 CONTINUE
  55. 20 CONTINUE
  56. GOTO 70
  57. 30 CONTINUE
  58. * C'EST UNE SURFACE OU UN VOLUME
  59. NBELEM=IPT1.NUM(/2)
  60. NBNN=IPT1.NUM(/1)
  61. NBFAC=LTEL(1,IPT1.ITYPEL)
  62. IAD=LTEL(2,IPT1.ITYPEL)-1
  63. IF (NBFAC.EQ.0) GOTO 70
  64. DO 65 IFAC=1,NBFAC
  65. ITYP=LDEL(1,IAD+IFAC)
  66. NPFAC=KDFAC(1,ITYP)
  67. IF (NPFAC.NE.0) THEN
  68. JAD=LDEL(2,IAD+IFAC)-1
  69. IDEP=KDFAC(2,ITYP)
  70. IFEP=IDEP+3*(KDFAC(3,ITYP)-1)
  71. DO 60 ITRIAN=IDEP,IFEP,3
  72. IAFA=LFAC(JAD+KFAC(ITRIAN))
  73. IBFA=LFAC(JAD+KFAC(ITRIAN+1))
  74. ICFA=LFAC(JAD+KFAC(ITRIAN+2))
  75. DO 40 IEL=1,NBELEM
  76. IPA=IPT1.NUM(IAFA,IEL)
  77. IPB=IPT1.NUM(IBFA,IEL)
  78. IPC=IPT1.NUM(ICFA,IEL)
  79. IA=ICPR(IPA)
  80. IB=ICPR(IPB)
  81. IC=ICPR(IPC)
  82. IF (IVU(IA).LT.1.OR.IVU(IB).LT.1.OR.IVU(IC).LT.1)
  83. # GOTO 40
  84. XA=XPROJ(1,IA)
  85. XB=XPROJ(1,IB)
  86. XC=XPROJ(1,IC)
  87. YA=XPROJ(2,IA)
  88. YB=XPROJ(2,IB)
  89. YC=XPROJ(2,IC)
  90. VAX=XP-XA
  91. VBX=XP-XB
  92. VCX=XP-XC
  93. VAY=YP-YA
  94. VBY=YP-YB
  95. VCY=YP-YC
  96. DC=VAX*VBY-VAY*VBX
  97. DA=VBX*VCY-VBY*VCX
  98. IF (DA*DC.LT.0.) GOTO 40
  99. DB=VCX*VAY-VCY*VAX
  100. IF (DA*DB.LT.0.) GOTO 40
  101. IF (DB*DC.LT.0.) GOTO 40
  102. if (mcham.eq.0) then
  103. VC = VCPCHA(IPC)
  104. else
  105. VC = velche(min(lval,ICFA),IEL)
  106. endif
  107. GOTO 90
  108. 40 CONTINUE
  109. 60 CONTINUE
  110. ELSE
  111. *
  112. * POLYGONE
  113. *
  114. DO 45, IEL = 1, NBELEM
  115. *
  116. * Recherche des coordonnees du centre du polygone
  117. *
  118. XXM = 0.
  119. YYM = 0.
  120. VVM = 0.
  121. IVUE = 1
  122. DO 67 ICT = 1, NBNN
  123. *
  124. NUPT = IPT1.NUM(ICT, IEL)
  125. IDPT = ICPR(NUPT)
  126. XXM = XPROJ(1,IDPT) + XXM
  127. YYM = XPROJ(2,IDPT) + YYM
  128.  
  129. if (mcham.eq.0) then
  130. VVM = VCPCHA(NUPT)
  131. else
  132. VVM = velche(min(lval,IAFA),IEL)
  133. endif
  134. IF (IVU(IDPT).NE.1) IVUE = 0
  135. *
  136. 67 CONTINUE
  137. *
  138. IF (IVUE.EQ.1) THEN
  139. *
  140. XC=XXM/NBNN
  141. YC=YYM/NBNN
  142. VC=VVM/NBNN
  143. *
  144. IAFA = NBNN
  145. IPA = IPT1.NUM(IAFA, IEL)
  146. ID2 = ICPR(IPA)
  147. XA=XPROJ(1,ID2)
  148. YA=XPROJ(2,ID2)
  149. *
  150. * Boucle sur tous les triangles
  151. *
  152. DO 670, ICT = 1, NBNN
  153. *
  154. IBFA = ICT
  155. IPB = IPT1.NUM(IBFA, IEL)
  156. ID1 = ICPR(IPB)
  157. *
  158. XB=XPROJ(1,ID1)
  159. YB=XPROJ(2,ID1)
  160.  
  161. VAX=XP-XA
  162. VBX=XP-XB
  163. VCX=XP-XC
  164. VAY=YP-YA
  165. VBY=YP-YB
  166. VCY=YP-YC
  167. DC=VAX*VBY-VAY*VBX
  168. DA=VBX*VCY-VBY*VCX
  169. IF (DA*DC.LT.0.) GOTO 675
  170. DB=VCX*VAY-VCY*VAX
  171. IF (DA*DB.LT.0.) GOTO 675
  172. IF (DB*DC.LT.0.) GOTO 675
  173. GOTO 90
  174.  
  175. 675 XA = XB
  176. YA = YB
  177. IPA = IPB
  178. IAFA = IBFA
  179. *
  180. 670 CONTINUE
  181. *
  182. ENDIF
  183. *
  184. 45 CONTINUE
  185. *
  186. ENDIF
  187. 65 CONTINUE
  188. 70 CONTINUE
  189. IF (LISOUS(/1).NE.0) SEGDES IPT1
  190. 220 CONTINUE
  191. SEGDES MELEME
  192. 80 CONTINUE
  193. * ON N'A PAS TROUVE ON TERMINE
  194. GOTO 1000
  195. * ON A TROUVE ON ECRIT CE QUE C'EST
  196. 95 CONTINUE
  197. DA=((XP-XA)**2+(YP-YA)**2)**0.5
  198. DB=((XP-XB)**2+(YP-YB)**2)**0.5
  199. DS=DA+DB
  200. IF (DS.EQ.0.) GOTO 400
  201. if (mcham.eq.0) then
  202. BONVAL=(VCPCHA(IPA)*DA+VCPCHA(IPB)*DB)/DS
  203. else
  204. BONVAL=(velche(min(lval,IAFA),IEL)*da+
  205. > velche(min(lval,IBFA),IEL)*db)/DS
  206. endif
  207. GOTO 97
  208. 90 CONTINUE
  209. DS=DA+DB+DC
  210. IF (DS.EQ.0.) GOTO 400
  211. if (mcham.eq.0) then
  212. BONVAL=(VCPCHA(IPA)*DA+VCPCHA(IPB)*DB+VC*DC)/DS
  213. else
  214. BONVAL=(velche(min(lval,IAFA),IEL)*da+
  215. > velche(min(lval,IBFA),IEL)*db+VC*dc)/DS
  216. endif
  217. 97 CONTINUE
  218. TEXT2='VALEUR : '
  219. WRITE (TEXT2(10:19),FMT='(1PG10.3)') BONVAL
  220. CALL TRMESS(TEXT2)
  221. SEGDES IPT1,MELEME
  222. 1000 CONTINUE
  223. * CALL TRTINI
  224. RETURN
  225. END
  226.  
  227.  
  228.  
  229.  
  230.  
  231.  
  232.  
  233.  
  234.  
  235.  
  236.  
  237.  
  238.  

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