Télécharger la plaquette Cast3M


fr en

Télécharger tetra2.eso

Retour à la liste

Numérotation des lignes : 

tetra2

  1. C TETRA2    SOURCE    PASCAL    22/08/03    21:15:01     11420          
  2. C---------------------------------------------------------------------|
  3. C                                                                     |
  4.        SUBROUTINE TETRA2(II,JJ,IF1,IF2,IGAGNE,IPTT)
  5. C                                                                     |
  6. C      CETTE SUBROUTINE TENTE DE CREER DEUX TETRAEDRES A PARTIR       |
  7. C      DES 2 TRIANGLES IF1 ET IF2.                                    |
  8. C                                                                     |
  9. C      - IGAGNE=1 EN CAS DE SUCCES                                    |
  10. C      - IGAGNE=0 EN CAS D'ECHEC                                      |
  11. C                                                                     |
  12. C---------------------------------------------------------------------|
  13. C
  14.       IMPLICIT INTEGER(I-N)
  15.       IMPLICIT REAL*8 (A-H,O-Z)
  16. -INC TDEMAIT
  17. -INC PPARAM
  18. -INC CCOPTIO
  19.        LOGICAL REPONS,FACET,SOLTET,DIAGO,IN2,VERDIV,IN
  20. C
  21.        if (iptt.gt.nptmax) then
  22.         IF (IVERB.EQ.1) write (6,*) ' tetra2 iptt nptmax ',iptt,nptmax
  23.        endif
  24.        nfcini=nfcmax
  25.        ip1=0
  26.        ip2=0
  27.        N3=0
  28.        N4=0
  29.        N5=0
  30.        N6=0
  31.        N7=0
  32.        ICTF=0
  33.        ICTV=0
  34.        ipas=0
  35.        ipin = 0
  36. C
  37. *      IF (.NOT.IN2(ii,IPTT,nfcini).or..NOT.IN2(jj,IPTT,nfcini)) THEN
  38. *       write (6,*) ' tetra2 test in2 echoue ',ii,jj,iptt
  39. *       RETURN
  40. *      ENDIF
  41.        IP=IPRED(IF1,II)
  42.        JP=ISUCC(IF2,II)
  43. *  CREATION FACETTE PREMIER ELEMENT
  44. *     recherche existence de la face
  45.        IF3=IFACE3(ii,iptt,ip)
  46. *      IF (IF3.ne.0) write (6,*) ' tetra2 if3 assimilee ',ii,iptt,ip
  47.        IF (IF3.eq.0) THEN
  48.         nfcmax=nfcmax+1
  49.         if3=nfcmax
  50.         NFC(1,IF3)=ii
  51.         NFC(2,IF3)=iptt
  52.         NFC(3,IF3)=ip
  53.         NFC(4,IF3)=0
  54.         N3=IF3
  55.         elseif (NFC(4,if3).ne.0.or.ipred(if3,ii).ne.iptt) then
  56. *        write (6,*) ' tetra2 probleme facette if3 ',if3
  57.          nfcmax=nfcini
  58.          return
  59.        endif
  60. *     recherche existence de la face
  61.        IF4=IFACE3(jj,ip,iptt)
  62. *      IF (IF4.ne.0) write (6,*) ' tetra2 if4 assimilee',jj,ip,iptt
  63.        IF (IF4.eq.0) THEN
  64.        NFCMAX=NFCMAX+1
  65.        IF4=NFCMAX
  66.        NFC(1,IF4)=jj
  67.        NFC(2,IF4)=ip
  68.        NFC(3,IF4)=iptt
  69.        NFC(4,IF4)=0
  70.         N4=IF4
  71.        elseif (NFC(4,if4).ne.0.or.ipred(if4,jj).ne.ip) then
  72. *         write (6,*) ' tetra2 probleme facette if4 ',if4
  73.          nfcmax=nfcini
  74.          return
  75.        endif
  76. *  creation facette commune (necessaire pour faire les verification)
  77.        IF7=IFACE3(ii,jj,iptt)
  78. *      IF (IF7.ne.0) write(6,*)'tetra2 facette if7 existe deja => echec'
  79. *      IF (IF7.ne.0) THEN
  80. *        nfcmax=nfcini
  81. *        return
  82. *      endif
  83. *      IF (IF7.ne.0) write (6,*) ' tetra2 if7 assimilee',jj,ip,iptt
  84.        IF (IF7.eq.0) THEN
  85.        NFCMAX=NFCMAX+1
  86.        IF7=NFCMAX
  87.        NFC(1,IF7)=ii
  88.        NFC(2,IF7)=jj
  89.        NFC(3,IF7)=iptt
  90.        NFC(4,IF7)=0
  91.         N7=IF7
  92.        elseif (NFC(4,if7).ne.0.or.ipred(if7,ii).ne.jj) then
  93. *         write (6,*) ' tetra2 probleme facette if7 ',if7
  94.          nfcmax=nfcini
  95.          return
  96.        endif
  97. *      nfcmoi=nfcmax   si on veut garder le 2eme element
  98.        nfcmoi=nfcini
  99. *  CREATION FACETTES 2eme element
  100. *     recherche existence de la face
  101.        IF5=IFACE3(ii,jp,iptt)
  102. *      IF (IF5.ne.0) write (6,*) ' tetra2 if5 assimilee',ii,jp,iptt
  103.        IF (IF5.eq.0) THEN
  104.        NFCMAX=NFCMAX+1
  105.        IF5=NFCMAX
  106.        NFC(1,IF5)=ii
  107.        NFC(2,IF5)=JP
  108.        NFC(3,IF5)=iptt
  109.        NFC(4,IF5)=0
  110.         N5=IF5
  111.        elseif (NFC(4,if5).ne.0.or.ipred(if5,ii).ne.jp) then
  112. *         write (6,*) ' tetra2 probleme facette if5 ',if5
  113.          nfcmax=nfcini
  114.          return
  115.        endif
  116. *     recherche existence de la face
  117.        IF6=IFACE3(jj,iptt,jp)
  118. *      IF (IF6.ne.0) write (6,*) ' tetra2 if6 assimilee',jj,iptt,jp
  119.        IF (IF6.eq.0) THEN
  120.        NFCMAX=NFCMAX+1
  121.        IF6=NFCMAX
  122.        NFC(1,IF6)=jj
  123.        NFC(2,IF6)=iptt
  124.        NFC(3,IF6)=jp
  125.        NFC(4,IF6)=0
  126.         N6=IF6
  127.        elseif (NFC(4,if6).ne.0.or.ipred(if6,jj).ne.iptt) then
  128. *         write (6,*) ' tetra2 probleme facette if6 ',if6
  129.          nfcmax=nfcini
  130.          return
  131.        endif
  132. *  si necessaire verification diago
  133. *  on se fait aussi une petite verif de longueur
  134.          IF (N3.NE.0.AND.N5.NE.0) then
  135.           IF (DIAGO(iptt,ii,diacrd)) GOTO 274
  136.           DNORM=(XYZ(1,IPTT)-XYZ(1,II))**2
  137.      #         +(XYZ(2,IPTT)-XYZ(2,II))**2
  138.      #         +(XYZ(3,IPTT)-XYZ(3,II))**2
  139.           DTEST=tetrl*XYZ(4,IPTT)*XYZ(4,II)
  140.           IF (DNORM.GT.DTEST.and.nptmax.ne.iptt) GOTO 275
  141.          ENDIF
  142.          IF (N4.NE.0.AND.N6.NE.0) then
  143.           IF (DIAGO(iptt,jj,diacrd)) GOTO 274
  144.           DNORM=(XYZ(1,IPTT)-XYZ(1,JJ))**2
  145.      #         +(XYZ(2,IPTT)-XYZ(2,JJ))**2
  146.      #         +(XYZ(3,IPTT)-XYZ(3,JJ))**2
  147.           DTEST=tetrl*XYZ(4,IPTT)*XYZ(4,JJ)
  148.           IF (DNORM.GT.DTEST.and.nptmax.ne.iptt) GOTO 275
  149.          ENDIF
  150.          IF (N3.NE.0.AND.N4.NE.0) then
  151.           IF (DIAGO(iptt,ip,diacrd)) GOTO 274
  152.           DNORM=(XYZ(1,IPTT)-XYZ(1,IP))**2
  153.      #         +(XYZ(2,IPTT)-XYZ(2,IP))**2
  154.      #         +(XYZ(3,IPTT)-XYZ(3,IP))**2
  155.           DTEST=tetrl*XYZ(4,IPTT)*XYZ(4,IP)
  156.           IF (DNORM.GT.DTEST.and.nptmax.ne.iptt) GOTO 275
  157.          ENDIF
  158.          IF (N3.NE.0) THEN
  159. *  TEST DU POINT MILIEU de if3
  160.           DO 242 I=1,4
  161.            XYZ(I,NPTMAX+3)=(XYZ(I,nfc(1,if3))+XYZ(I,nfc(2,if3))+
  162.      >                      XYZ(I,nfc(3,if3)))/3
  163.  242      CONTINUE
  164. *         call vcrit(nptmax+3)
  165. *         CALL DIST(nptmax+3,nptaux,GL,IOK,II,JJ,IP,JP,iptt,0,0,0,0,0)
  166. *         IF (IOK.EQ.0) goto 277
  167.          ENDIF
  168.          IF (N4.NE.0) THEN
  169. *  TEST DU POINT MILIEU de if4
  170.           DO 243 I=1,4
  171.            XYZ(I,NPTMAX+3)=(XYZ(I,nfc(1,if4))+XYZ(I,nfc(2,if4))+
  172.      >                      XYZ(I,nfc(3,if4)))/3
  173.  243      CONTINUE
  174. *         call vcrit(nptmax+3)
  175. *         CALL DIST(nptmax+3,nptaux,GL,IOK,II,JJ,IP,JP,iptt,0,0,0,0,0)
  176. *         IF (IOK.EQ.0) goto 277
  177.          ENDIF
  178.          IF (N5.NE.0) THEN
  179. *  TEST DU POINT MILIEU de if7
  180.           DO 244 I=1,4
  181.            XYZ(I,NPTMAX+3)=(XYZ(I,nfc(1,if7))+XYZ(I,nfc(2,if7))+
  182.      >                      XYZ(I,nfc(3,if7)))/3
  183.  244      CONTINUE
  184. *         call vcrit(nptmax+3)
  185. *         CALL DIST(nptmax+3,nptaux,GL,IOK,II,JJ,IP,JP,iptt,0,0,0,0,0)
  186. *         IF (IOK.EQ.0) goto 277
  187.          ENDIF
  188.          goto 276
  189.  274     continue
  190.          nfcmax=nfcini
  191. *        write (6,*) ' tetra2 echec diago 1 ',ii,jj,ip,jp,iptt
  192.          return
  193.  275     continue
  194.          nfcmax=nfcini
  195. *        write (6,*) ' tetra2 echec longueur 1'
  196.          return
  197.  277     continue
  198.          nfcmax=nfcini
  199. *        write (6,*) ' tetra2 dist pt milieu'
  200.          return
  201.  278     continue
  202.          nfcmax=nfcini
  203. *        write (6,*) ' tetra2 gl pt milieu'
  204.          return
  205.  276     continue
  206. C
  207.        CALL REPSUB(IF1)
  208.        CALL REPSUB(IF3)
  209.        CALL REPSUB(IF4)
  210.        CALL REPSUB(IF7)
  211. *  verification du premier element
  212.         IF (.NOT.SOLTET(IF1,IF3,IF4,IF7,IPIN)) then
  213. *         write (6,*) 'tetra2 soltet invalide - 1',ii,ip,iptt,jj
  214.           GOTO 160
  215.         ENDIF
  216.          IF (.NOT.FACET(IF3))     then
  217. *          write(6,*) ' tetra2 facet if3 invalide'
  218.            GOTO 160
  219.          ENDIF
  220.          IF (.NOT.FACET(IF4))     then
  221. *          write(6,*) ' tetra2 facet if4 invalide'
  222.            GOTO 160
  223.          ENDIF
  224.          IF (.NOT.FACET(IF7))     then
  225. *          write(6,*) ' tetra2 facet if7 invalide'
  226.            GOTO 160
  227.          ENDIF
  228. *
  229.          IF (N5.NE.0.AND.N6.NE.0) then
  230.           IF (DIAGO(iptt,jp,diacrd)) GOTO 284
  231.           DNORM=(XYZ(1,IPTT)-XYZ(1,JP))**2
  232.      #         +(XYZ(2,IPTT)-XYZ(2,JP))**2
  233.      #         +(XYZ(3,IPTT)-XYZ(3,JP))**2
  234.           DTEST=tetrl*XYZ(4,IPTT)*XYZ(4,JP)
  235.           IF (DNORM.GT.DTEST.and.nptmax.ne.iptt) GOTO 285
  236.          ENDIF
  237.          IF (N5.NE.0) THEN
  238. *  TEST DU POINT MILIEU de if5
  239.           DO 245 I=1,4
  240.            XYZ(I,NPTMAX+3)=(XYZ(I,nfc(1,if5))+XYZ(I,nfc(2,if5))+
  241.      >                      XYZ(I,nfc(3,if5)))/3
  242.  245      CONTINUE
  243. *         call vcrit(nptmax+3)
  244. *         CALL DIST(nptmax+3,nptaux,GL,IOK,II,JJ,IP,JP,iptt,0,0,0,0,0)
  245. *         IF (IOK.EQ.0) goto 287
  246.          ENDIF
  247.          IF (N6.NE.0) THEN
  248. *  TEST DU POINT MILIEU de if6
  249.           DO 246 I=1,4
  250.            XYZ(I,NPTMAX+3)=(XYZ(I,nfc(1,if6))+XYZ(I,nfc(2,if6))+
  251.      >                      XYZ(I,nfc(3,if6)))/3
  252.  246      CONTINUE
  253. *         call vcrit(nptmax+3)
  254. *         CALL DIST(nptmax+3,nptaux,GL,IOK,II,JJ,IP,JP,iptt,0,0,0,0,0)
  255. *         IF (IOK.EQ.0) goto 287
  256.          ENDIF
  257.          goto 286
  258.  284     continue
  259.          nfcmax=nfcmoi
  260. *         write (6,*) ' tetra2 echec diago 2 ',ii,jj,ip,jp,iptt
  261.          goto 160
  262.  285     continue
  263.          nfcmax=nfcmoi
  264. *         write (6,*) ' tetra2 echec longueur 2'
  265.          goto 160
  266.  287     continue
  267.          nfcmax=nfcmoi
  268. *         write (6,*) ' tetra2 echec dist 2'
  269.          goto 160
  270.  288     continue
  271.          nfcmax=nfcmoi
  272. *         write (6,*) ' tetra2 echec gl 2'
  273.          goto 160
  274.  286     continue
  275.        CALL REPSUB(IF2)
  276.        CALL REPSUB(IF5)
  277.        CALL REPSUB(IF6)
  278.        CALL REPSUB(IF7)
  279. *  verification du deuxieme element element
  280.        IF (.NOT.SOLTET(IF2,IF5,IF6,IF7,IPIN)) then
  281. *         write (6,*) 'tetra2 soltet invalide - 2 ',ii,jp,iptt,jj
  282.          GOTO 165
  283.        endif
  284.          IF (.NOT.FACET(IF5))     then
  285. *          write(6,*) ' tetra2 facet if5 invalide'
  286.            GOTO 165
  287.          ENDIF
  288.          IF (.NOT.FACET(IF6))     then
  289. *          write(6,*) ' tetra2 facet if6 invalide'
  290.            GOTO 165
  291.          ENDIF
  292. *  CREATION premier ELEMENT
  293.        IGAGNE=1
  294.        NVOL=NVOL+1
  295.        IVOL(9,NVOL)=25
  296.        IF (NFV(1,IF1).EQ.0) NFV(1,IF1)=NVOL
  297.        IF (NFV(1,IF1).NE.NVOL) NFV(2,IF1)=NVOL
  298.        IF (NFV(1,IF3).EQ.0) NFV(1,IF3)=NVOL
  299.        IF (NFV(1,IF3).NE.NVOL) NFV(2,IF3)=NVOL
  300.        IF (NFV(1,IF4).EQ.0) NFV(1,IF4)=NVOL
  301.        IF (NFV(1,IF4).NE.NVOL) NFV(2,IF4)=NVOL
  302.        DO 254 I=1,3
  303.           IVOL(I,NVOL)=NFC(I,IF1)
  304. 254    CONTINUE
  305.        IVOL(4,NVOL)=IPTT
  306.        qual=qualt(ii,jj,ip,iptt)
  307.        if (iimpi.eq.1) write (6,1100) nvol,nfacet,qual,
  308.      >   (ivol(i,nvol),i=1,4)
  309.  1100  format (' TETRA2 ',i5,i6,f8.4,4i6)
  310. *  CREATION deuxieme ELEMENT
  311.        NVOL=NVOL+1
  312.        IVOL(9,NVOL)=25
  313.        IF (NFV(1,IF2).EQ.0) NFV(1,IF2)=NVOL
  314.        IF (NFV(1,IF2).NE.NVOL) NFV(2,IF2)=NVOL
  315.        IF (NFV(1,IF5).EQ.0) NFV(1,IF5)=NVOL
  316.        IF (NFV(1,IF5).NE.NVOL) NFV(2,IF5)=NVOL
  317.        IF (NFV(1,IF6).EQ.0) NFV(1,IF6)=NVOL
  318.        IF (NFV(1,IF6).NE.NVOL) NFV(2,IF6)=NVOL
  319.        DO 256 I=1,3
  320.           IVOL(I,NVOL)=NFC(I,IF2)
  321. 256    CONTINUE
  322.        IVOL(4,NVOL)=IPTT
  323.        qual=qualt(jj,ii,jp,iptt)
  324.        if (iimpi.eq.1) write (6,1100) nvol,nfacet,qual,
  325.      >   (ivol(i,nvol),i=1,4)
  326.        IGAGNE=1
  327.        RETURN
  328. 165    continue
  329.        CALL REPSUB(IF7)
  330.        CALL REPSUB(IF6)
  331.        CALL REPSUB(IF5)
  332.        CALL REPSUB(IF2)
  333.        nfcmax=nfcmoi
  334. *        if (nptmax.eq.iptt)
  335. *    >    write (6,*) ' tetra2 echec 2eme element'
  336. *      return  on ne fait aucun element
  337. 160    continue
  338.        CALL REPSUB(IF7)
  339.        CALL REPSUB(IF4)
  340.        CALL REPSUB(IF3)
  341.        CALL REPSUB(IF1)
  342.          nfcmax=nfcini
  343.          return
  344.        RETURN
  345.        END
  346.  
  347.  
  348.  
  349.  
  350.  
  351.  
  352.  

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