Télécharger la plaquette Cast3M


fr en

Télécharger isoint.eso

Retour à la liste

Numérotation des lignes : 

isoint

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

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