Télécharger la plaquette Cast3M


fr en

Télécharger faced.eso

Retour à la liste

Numérotation des lignes : 

faced

  1. C FACED     SOURCE    PV        18/06/15    21:15:01     9859           
  2. C TRACE D'UN OBJET PAR FACE EN COMMENCANT PAR CELLES DE DERRIERE
  3. C
  4. C  imod=0 trace en couleur d'effacement
  5. C  imod=1 trace en couleir normale
  6. C  SG 2016/07/18 Programmation comme envvo2 pour gerer les faces TRI7/QUA9
  7. C
  8.       SUBROUTINE FACED(MELEME,XPROJ,ICPR,IVU,MCOUP,KON,LNDEGR,imod)
  9.       IMPLICIT INTEGER(I-N)
  10.  
  11. -INC PPARAM
  12. -INC CCOPTIO
  13. -INC SMELEME
  14. -INC CCGEOME
  15. -INC CCREEL
  16. C+PP DEGRADE OU NON
  17.       LOGICAL lndegr
  18. C+PP
  19.       SEGMENT XPROJ(3,1)
  20.       SEGMENT ICPR(1)
  21.       SEGMENT IVU(ITE)
  22.       SEGMENT MCOUP(0)
  23.       SEGMENT KON(3,NBCON,NMAX)
  24. *
  25. *     Type de faces prises en compte: T3, Q4, T6, Q8, POLY, T7, Q9
  26. *     Numero dans KDFAC               1   2   3   4     6    7   8
  27. * Pour ne pas se prendre la tête,  on numerote pareil que KDFAC
  28. * Pour les 5 (non utilisé), 6 (polygone) et >8, ca restera à 0
  29. *  NTYFAC=20, codé en dur dans CCGEOME pour KDFAC
  30.       PARAMETER (NTYFAC=20)
  31. * Nb de faces de chaque type, sert également de compteur
  32.       SEGMENT NBFAC(NTYFAC)
  33. * Un segment pointant sur les IFACI
  34.       SEGMENT IPOFAC(NTYFAC)
  35. *     Segment IFACI contenant les noeuds, la couleur et si la face d'un
  36. *     type donné est vue ou non
  37.       SEGMENT IFACI(NNODE+2,NFACI)
  38. *     Nombre de noeuds max pour les polygones
  39.       PARAMETER (NNOMAX=14)
  40. *
  41.       SEGMENT NSOMP(NFACP)
  42.       SEGMENT IFACOL(NFAC)
  43.       SEGMENT TFAC(NFAC)
  44.       SEGMENT KFAK(NFAC)
  45.       SEGMENT NAUX(max(2,NFAC))
  46.       DIMENSION XTR(NNOMAX),YTR(NNOMAX),ZTR(NNOMAX),NPTR(NNOMAX)
  47.       DIMENSION XTR2(3),YTR2(3),ZTR2(3)
  48. *
  49. *dbg      write(ioimp,*) 'coucou faced lndegr=',LNDEGR,' imod=',imod
  50.  
  51.       SEGACT MELEME
  52.       MELSAU=MELEME
  53.       IPT1=MELEME
  54. *     IF (MCOUP.NE.0) THEN
  55. *      NBNN=0
  56. *      NBELEM=0
  57. *      NBREF=0
  58. *      NBSOUS=LISOUS(/1)-1
  59. *      SEGINI IPT1
  60. *      DO 5 I=1,NBSOUS
  61. *      IPT1.LISOUS(I)=LISOUS(I)
  62. *   5  CONTINUE
  63. *      ISCOUP=LISOUS(NBSOUS+1)
  64. *     ENDIF
  65. *     call ecmail(ipt1,0)
  66.       CALL ECROBJ('MAILLAGE',IPT1)
  67.       CALL ENVELO
  68. *      IF (MCOUP.NE.0) SEGSUP IPT1
  69.       CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
  70.       IF (IERR.NE.0) RETURN
  71.       SEGACT MELEME
  72. *      IF (MCOUP.NE.0) THEN
  73. *        IF (LISOUS(/1).NE.0) THEN
  74. *         NBSOUS=LISOUS(/1)+1
  75. *         SEGADJ MELEME
  76. *         LISOUS(NBSOUS)=ISCOUP
  77. *        ELSE
  78. *         NBSOUS=2
  79. *         SEGINI IPT1
  80. *         IPT1.LISOUS(1)=MELEME
  81. *         IPT1.LISOUS(2)=ISCOUP
  82. *         MELEME=IPT1
  83. *        ENDIF
  84. *      ENDIF
  85.       SEGACT XPROJ,ICPR
  86.       SEGACT KON*MOD
  87.       NBCON=KON(/2)
  88.       NBCONR=NBCON-1
  89.       NBPOIN=XPROJ(/2)
  90.       TMIN=xsgran
  91.       TMAX=-xsgran
  92.       DO 1 I=1,NBPOIN
  93.          TMIN=MIN(TMIN,XPROJ(3,I))
  94.          TMAX=MAX(TMAX,XPROJ(3,I))
  95.  1    CONTINUE
  96.       TDIST=TMAX-TMIN
  97. c
  98. c     on compte le nombre d elements dont les faces sont de type 1 2 3 4
  99. c     6 7 8 dans NBFAC, attention à 6 : gestion des polygones
  100.       SEGINI NBFAC
  101.       IPT1=MELEME
  102.       SEGACT MELEME
  103.       DO 10 IOB=1,MAX(1,LISOUS(/1))
  104.          IF (LISOUS(/1).NE.0) THEN
  105.             IPT1=LISOUS(IOB)
  106.             SEGACT IPT1
  107.          ENDIF
  108.          NBELEM=IPT1.NUM(/2)
  109.          ILTEL=LTEL(1,IPT1.ITYPEL)
  110.          IF (ILTEL.EQ.0) GOTO 12
  111.          ILTAD=LTEL(2,IPT1.ITYPEL)
  112.          DO 13 IF=1,ILTEL
  113.             IFT=LDEL(1,ILTAD+IF-1)
  114.             NBFAC(IFT)=NBFAC(IFT)+NBELEM
  115.  13      CONTINUE
  116.  12      CONTINUE
  117.  10   CONTINUE
  118. *
  119.       NFACP=NBFAC(6)
  120.       SEGINI NSOMP
  121. c==== CREATION DES FACES ==============================================
  122. * Initialisation des IFACI
  123.       SEGINI IPOFAC
  124.       DO ITYFAC=1,NTYFAC
  125.          NNODE=KDFAC(1,ITYFAC)
  126. * Polygone
  127.          IF (ITYFAC.EQ.6) NNODE=NNOMAX
  128.          IF (NNODE.GT.0) THEN
  129.             NFACI=NBFAC(ITYFAC)
  130.             SEGINI IFACI
  131.             IPOFAC(ITYFAC)=IFACI
  132.          ENDIF
  133.       ENDDO
  134. c     NBFAC sert maintenant de compteur
  135.       DO ITYFAC=1,NTYFAC
  136.          NBFAC(ITYFAC)=0
  137.       ENDDO
  138.       ICOUPE=0
  139.       DO 50 IOB=1,MAX(1,LISOUS(/1))
  140.          IF (LISOUS(/1).NE.0) THEN
  141.             IPT1=LISOUS(IOB)
  142.             ICOUPE=0
  143.             IF (IOB.EQ.LISOUS(/1).AND.MCOUP.NE.0) ICOUPE=1
  144.          ENDIF
  145.          NBELEM=IPT1.NUM(/2)
  146.          ILTEL=LTEL(1,IPT1.ITYPEL)
  147.          IF (ILTEL.EQ.0) GOTO 52
  148.          ILTAD=LTEL(2,IPT1.ITYPEL)
  149.          DO 60 IF=1,ILTEL
  150.             ITYFAC=LDEL(1,ILTAD+IF-1)
  151.             IAD=LDEL(2,ILTAD+IF-1)
  152.             NNODE=KDFAC(1,ITYFAC)
  153.             NNODF=NNODE
  154. * Polygone
  155.             IF (ITYFAC.EQ.6) THEN
  156.                NBNN=IPT1.NUM(/1)
  157. *  23 1
  158. *Erreur dans le module de trace
  159.                IF (NBNN.GT.NNOMAX) THEN
  160.                   CALL ERREUR(23)
  161.                   RETURN
  162.                ENDIF
  163.                NNODE=NBNN
  164.                NNODF=NNOMAX
  165.             ENDIF
  166.             IF (NNODE.GT.0) THEN 
  167.                IFACI=IPOFAC(ITYFAC)
  168.                DO 70 IEL=1,NBELEM
  169.                   NBFAC(ITYFAC)=NBFAC(ITYFAC)+1
  170.                   j=NBFAC(ITYFAC)
  171. * Polygone
  172.                   IF (ITYFAC.EQ.6) NSOMP(j)=NNODE
  173.                   IFACI(NNODF+2,j)=1
  174.                   DO i=1,NNODE
  175.                      IFACI(i,j)=ICPR(IPT1.NUM(LFAC(IAD+i-1),IEL))
  176.                      IF (IVU(IFACI(i,j)).NE.1) IFACI(NNODF+2,j)=0
  177.                   ENDDO
  178.                   IFACI(NNODF+1,j)=IPT1.ICOLOR(IEL)
  179. * TRI3 cas des coupes
  180.                   IF (ITYFAC.EQ.1) THEN
  181.                      IF (ICOUPE.EQ.1) THEN
  182.                         IF (MCOUP(IEL)/8.EQ.1) IFACI(NNODF+2,j)=2
  183.                         IF (MCOUP(IEL)/16.EQ.1) IFACI(NNODF+2,j)=3
  184.                      ENDIF
  185.                   ENDIF
  186.  70            CONTINUE
  187.             ENDIF
  188.  60      CONTINUE
  189.  52      CONTINUE
  190.          IF (LISOUS(/1).NE.0) SEGDES IPT1
  191.  50   CONTINUE
  192.       SEGDES MELEME
  193. C  IF FAUT MAINTENANT RETASSER ET CLASSER LES TABLEAUX DES FACES
  194. C  PROBLEME ELLES NE SONT PAS FORCEMENT DECRITES DE LA MEME FACON
  195.       NFAC=0
  196.       DO ITYFAC=1,NTYFAC
  197.          NFAC=NFAC+NBFAC(ITYFAC)
  198.       ENDDO
  199.       SEGINI TFAC,KFAK,IFACOL
  200.       IFAC=0
  201.       DO ITYFAC=1,NTYFAC
  202.          NNODE=KDFAC(1,ITYFAC)
  203.          IF (ITYFAC.EQ.6) THEN
  204.             NNODF=NNOMAX
  205.          ELSE
  206.             NNODF=NNODE
  207.          ENDIF
  208.          IF (NNODE.GT.0.OR.ITYFAC.EQ.6) THEN
  209.             IFACI=IPOFAC(ITYFAC)
  210.             DO I=1,NBFAC(ITYFAC)
  211.                IFAC=IFAC+1
  212. * Polygone
  213.                IF (ITYFAC.EQ.6) NNODE=NSOMP(I)
  214.                XXXX = 0.
  215.                DO J=1,NNODE
  216. * ligne suivante : erreur de faced pour poly ?
  217. *                  XXXX = XXXX + XPROJ(3,ICPR(IFACI(J,I)))
  218.                   XXXX = XXXX + XPROJ(3,IFACI(J,I))
  219.                ENDDO
  220.                XXXX=XXXX/NNODE
  221.                TFAC(IFAC)=XXXX
  222.                IF (IFACI(NNODF+2,I).EQ.1) TFAC(IFAC)=TFAC(IFAC)-TDIST
  223.                IFACOL(IFAC)=IFACI(NNODF+1,I)
  224.                KFAK(IFAC)=I+((ITYFAC-1)*NFAC)
  225. * TRI3/coupe
  226.                IF (ITYFAC.EQ.1) THEN
  227.                   IF (IFACI(NNODF+2,I).EQ.2) TFAC(I)=TFAC(IFAC)-2*TDIST
  228.                   IF (IFACI(NNODF+2,I).EQ.3) KFAK(IFAC)=0
  229.                ENDIF
  230.             ENDDO
  231.          ENDIF
  232.       ENDDO
  233. C  IL N'Y A PLUS QU'A TRIER ET RETASSER KFAK SUIVANT TFAC
  234.       SEGINI NAUX
  235.       IF (IDIM.EQ.2) GOTO 209
  236.       NAUX(1)=1
  237.       NAUX(2)=NFAC
  238.       IZ=2
  239.  208  IZ=IZ-1
  240.       IF (IZ.LE.0) GOTO 209
  241.       IPB=NAUX(IZ*2-1)
  242.       IPH=NAUX(IZ*2)
  243.       IF(IPB.GE.IPH) GOTO 208
  244.       JPB=IPB-1
  245.       JPH=IPH+1
  246. C  CALCUL DU PIVOT
  247.       PV=0.
  248. *     DO 207 J=IPB,IPH
  249. *     PV=PV+TFAC(J)
  250. *207  CONTINUE
  251. *     PV=PV/(IPH-IPB+1)
  252.       PV=(TFAC(IPB)+TFAC(IPH))/2.
  253.  242  JPB=JPB+1
  254.       IF (JPH.EQ.JPB) GOTO 245
  255.       IF (TFAC(JPB).LT.PV) GOTO 243
  256.       GOTO 242
  257.  243  JPH=JPH-1
  258.       IF (JPH.EQ.JPB) GOTO 245
  259.       IF (TFAC(JPH).GT.PV) GOTO 244
  260.       GOTO 243
  261.  244  IAUX=KFAK(JPB)
  262.       IAUXX=IFACOL(JPB)
  263.       KFAK(JPB)=KFAK(JPH)
  264.       IFACOL(JPB)=IFACOL(JPH)
  265.       KFAK(JPH)=IAUX
  266.       IFACOL(JPH)=IAUXX
  267.       TAUX=TFAC(JPB)
  268.       TFAC(JPB)=TFAC(JPH)
  269.       TFAC(JPH)=TAUX
  270.       GOTO 242
  271.  245  IF (JPB.GE.IPB) GOTO 247
  272.       JPB=JPB+1
  273.       JPH=JPH+2
  274.       GOTO 248
  275.  247  IF (JPH.LE.IPH) GOTO 249
  276.       JPB=JPB-2
  277.       JPH=JPH-1
  278.       GOTO 248
  279.  249  IF (TFAC(JPB).LE.PV) GOTO 250
  280.       IF (JPH.EQ.IPH) GOTO 251
  281.  252  JPH=JPH+1
  282.       GOTO 248
  283.  250  IF (JPB.EQ.IPB) GOTO 252
  284.  251  JPB=JPB-1
  285.  248  IF (JPB.EQ.IPB) GOTO 253
  286.       NAUX(2*IZ)=JPB
  287.       IZ=IZ+1
  288.  253  IF (JPH.EQ.IPH) GOTO 208
  289.       NAUX(2*IZ)=IPH
  290.       NAUX(2*IZ-1)=JPH
  291.       IZ=IZ+1
  292.       GOTO 208
  293.  209  CONTINUE
  294. C  LES FACES SONT CLASSEES DANS KFAK LES FACES ON ETE ELIMINEES PAR
  295. C  ENVELO .   IL NE RESTE PLUS QU'A TRACER
  296.       DO 300 I=1,NFAC
  297.          IFF=KFAK(I)
  298.          IF (IFF.EQ.0) GOTO 300
  299.          IT=(IFF-1)/NFAC
  300.          IF=IFF-IT*NFAC
  301.          IT=IT+1
  302.          IOK=0
  303. *     
  304.          ITYFAC=IT
  305.          NNODE=KDFAC(1,ITYFAC)
  306.          IF (ITYFAC.EQ.6) NNODE=NSOMP(IF)
  307.          IF (NNODE.GT.0) THEN
  308.             IFACI=IPOFAC(ITYFAC)
  309.             DO IP=1,NNODE
  310.                XTR(IP)=XPROJ(1,IFACI(IP,IF))
  311.                YTR(IP)=XPROJ(2,IFACI(IP,IF))
  312.                ZTR(IP)=XPROJ(3,IFACI(IP,IF))
  313.                NPTR(IP)=IFACI(IP,IF)
  314.                IF (IVU(IFACI(IP,IF)).EQ.1) IOK=1
  315. *!!               write(ioimp,*) 'ip=',ip,' x y z n iok',xtr(ip),ytr(ip),
  316. *!!     $              ztr(ip), iok
  317.             ENDDO
  318.          ENDIF
  319.          IF (IOK.EQ.0) GOTO 300
  320.          NP=NNODE
  321. * SG Pour les TRI7,QUA9 seuls les points du contour sont pris en compte
  322. *    pour le calcul de la normale et la suppression des points du contour.
  323.          IF (ITYFAC.EQ.7.OR.ITYFAC.EQ.8) NP=NP-1
  324. *!!         write(ioimp,*) 'np=',np
  325. C  DETERMINATION DE LA COULEUR D'APRES L'ORIENTATION DE LA NORMALE
  326.          XN=0.
  327.          YN=0.
  328.          ZN=0.
  329.          XDE=XTR(NP)
  330.          YDE=YTR(NP)
  331.          ZDE=ZTR(NP)
  332.          XW1=XTR(1)-XDE
  333.          YW1=YTR(1)-YDE
  334.          ZW1=ZTR(1)-ZDE
  335.          DO 900 I2=2,NP-1
  336.             XW2=XTR(I2)-XDE
  337.             YW2=YTR(I2)-YDE
  338.             ZW2=ZTR(I2)-ZDE
  339.             XN=XN+(YW1*ZW2-ZW1*YW2)
  340.             YN=YN+(ZW1*XW2-XW1*ZW2)
  341.             ZN=ZN+(XW1*YW2-YW1*XW2)
  342.             XW1=XW2
  343.             YW1=YW2
  344.             ZW1=ZW2
  345.  900     CONTINUE
  346.          DN=SQRT(XN**2+YN**2+ZN**2)
  347.          IF (DN.EQ.0.) DN=1.
  348.          ZN=ASIN(ABS(ZN/DN))
  349. C+PP DEGRADE OU NON
  350.          IF (lndegr) ZN=REAL(XPI/2.D0)
  351. C+PP
  352.          IFACO=IFACOL(I)
  353.          if (imod.eq.0) ifaco=8
  354. * SG Pour les TRI7 et QUA9, on choisit de decouper en TRI3 :
  355. *    idealement, on aurait mis le calcul de la normale dedans
  356.          IF (ITYFAC.EQ.7.OR.ITYFAC.EQ.8) THEN
  357.             XTR2(1)=XTR(NP+1)
  358.             YTR2(1)=YTR(NP+1)
  359.             ZTR2(1)=ZTR(NP+1)
  360.             DO IPO=1,NP
  361.                IPOP=IPO+1
  362.                IF (IPOP.GT.NP) IPOP=1
  363.                XTR2(2)=XTR(IPO)
  364.                YTR2(2)=YTR(IPO)
  365.                ZTR2(2)=ZTR(IPO)
  366.                XTR2(3)=XTR(IPOP)
  367.                YTR2(3)=YTR(IPOP)
  368.                ZTR2(3)=ZTR(IPOP)
  369.                CALL TRFACE(3,XTR2,YTR2,ZTR2,ZN,IFACO,IEFF)
  370.                if (imod.eq.0) ieff=0
  371.             ENDDO
  372.          ELSE
  373.             CALL TRFACE(NP,XTR,YTR,ZTR,ZN,IFACO,IEFF)
  374.          ENDIF
  375.  
  376.  
  377.          if (imod.eq.0) ieff=0
  378. C  SI IEFF <> 0 IL FAUT METTRE LES TRAITS EN EFFACEMENT
  379.          N1=NPTR(NP)
  380.          DO 450 IIP=1,NP
  381.             N2=NPTR(IIP)
  382.             NI=N1
  383.             NJ=N2
  384. * 459        CONTINUE
  385.  457        DO 454 K=1,NBCONR
  386.                IF (KON(1,K,NI).NE.NJ) GOTO 454
  387. C  8 = EFFACEMENT
  388.                KON(2,K,NI)=8
  389.                IF (IEFF.EQ.0) KON(2,K,NI)=IFACOL(I)
  390.                GOTO 456
  391.  454        CONTINUE
  392.             IF (KON(1,NBCON,NI).EQ.0) GOTO 456
  393.             NI=KON(1,NBCON,NI)
  394.             GOTO 457
  395.  456        CONTINUE
  396.             NI=N2
  397.             NJ=N1
  398. * 469        CONTINUE
  399.  467        DO 464 K=1,NBCONR
  400.                IF (KON(1,K,NI).NE.NJ) GOTO 464
  401. C     8 = EFFACEMENT
  402.                KON(2,K,NI)=8
  403.                IF (IEFF.EQ.0) KON(2,K,NI)=IFACOL(I)
  404.                GOTO 466
  405.  464        CONTINUE
  406.             IF (KON(1,NBCON,NI).EQ.0) GOTO 466
  407.             NI=KON(1,NBCON,NI)
  408.             GOTO 467
  409.  466        CONTINUE
  410.             N1=N2
  411.  450     CONTINUE
  412.  300  CONTINUE
  413. C'EST FINI
  414.       SEGACT MELEME
  415.       IF (LISOUS(/1).NE.0) THEN
  416.          NBSOUS=LISOUS(/1)
  417. *     IF (MCOUP.NE.0) NBSOUS=NBSOUS-1
  418.          DO 490 IO=1,NBSOUS
  419.             IPT2=LISOUS(IO)
  420.             segact ipt2
  421.             if (ipt2.itypel.gt.3.AND.ipt2.itypel.NE.32) SEGSUP IPT2
  422.  490     CONTINUE
  423.       ENDIF
  424.       if ((itypel.eq.0) .AND. (MELEME .NE. MELSAU)) SEGSUP MELEME
  425.       MELEME=MELSAU
  426.       SEGDES KON
  427.       DO ITYFAC=1,NTYFAC
  428.          IFACI=IPOFAC(ITYFAC)
  429.          IF (IFACI.NE.0) THEN
  430.             SEGSUP IFACI
  431.          ENDIF
  432.       ENDDO
  433.       SEGSUP IPOFAC
  434.       SEGSUP NBFAC
  435.       SEGSUP NAUX,TFAC,KFAK,IFACOL,NSOMP
  436.       RETURN
  437.       END
  438.  
  439.  
  440.  
  441.  
  442.  
  443.  
  444.  
  445.  
  446.  
  447.  
  448.  
  449.  
  450.  
  451.  
  452.  
  453.  
  454.  
  455.  
  456.  
  457.  
  458.  
  459.  
  460.  
  461.  
  462.  
  463.  

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