Télécharger la plaquette Cast3M


fr en

Télécharger pyra1.eso

Retour à la liste

Numérotation des lignes : 

pyra1

  1. C PYRA1     SOURCE    JC220346  16/11/29    21:15:30     9221           
  2. C---------------------------------------------------------------------|
  3. C                                                                     |
  4.        SUBROUTINE PYRA1(II,JJ,IF1,IF2,IGAGNE,IBOUT)
  5. C                                                                     |
  6. C      CETTE SUBROUTINE TENTE DE CREER UNE PYRAMIDE A PARTIR          |
  7. C      DU TRIANGLE IF1 ET DU QUADRANGLE IF2.                          |
  8. C      - IGAGNE=1 EN CAS DE SUCCES                                    |
  9. C      - IGAGNE=0 EN CAS D'ECHEC                                      |
  10. C                                                                     |
  11. C---------------------------------------------------------------------|
  12. C
  13.       IMPLICIT INTEGER(I-N)
  14.       IMPLICIT REAL*8(A-H,O-Z)
  15. -INC TDEMAIT
  16.  
  17. -INC PPARAM
  18. -INC CCOPTIO
  19.        LOGICAL REPONS,FACET,SOLPYR,SOLTET,DIAGO,IN2,VERDIV,IN
  20. C
  21. *      WRITE(6,1000)
  22. 1000   FORMAT(' ----->>> PYRA1 <<<-----')
  23. C
  24. *   on se refuse a mailler une pyramide trop ouverte
  25. *       if (TETA(IF1,IF2,II,JJ).lt.-100) goto 155
  26.        nptini=nptmax
  27.        nfcini=nfcmax
  28.        ICTF=0
  29.        ICTV=0
  30.        N3=0
  31.        N4=0
  32.        N5=0
  33.        ipin = 0
  34. *      write (6,*) 'entree dans pyra1 ii jj if1 if2 ',ii,jj,if1,if2
  35. *      write (6,*) ' liste des facettes '
  36. *      DO 443 I=1,NFCMAX
  37. *       IF (IFAT(I).EQ.1) GOTO 443
  38. *       WRITE (6,*)  I,NFC(1,I),NFC(2,I),NFC(3,I),NFC(4,I)
  39. *443  CONTINUE
  40. C
  41. C      RECHERCHE D'UNE 3EME FACETTE IF3
  42. C      --------------------------------
  43.        IP1=IPRED(IF1,II)
  44.        JP1=ISUCC(IF2,II)
  45.        JP2=IPRED(IF2,JJ)
  46. *
  47.        if (TETA(IF1,IF2,II,JJ).lt.-100) goto 250
  48. C
  49.        IF3=IFACE3(IP1,II,JP1)
  50. C
  51.        IF (IF3.NE.0) THEN
  52. *  si if3 dans le mauvais sens rien a faire
  53.        if (isucc(if3,ii).ne.ip1) then
  54.         IF (IVERB.EQ.1) write (6,*) ' pyra1 face a l''envers if3 '
  55.         return
  56.        endif
  57.         IF (NFC(4,IF3).NE.0) THEN
  58.          CALL prism1(ii,jp1,IF2,IF3,IGAGNE)
  59.          RETURN
  60.         ENDIF
  61. *         WRITE(6,1010)IF3
  62. 1010      FORMAT(' ** IF3=',I4)
  63.         N3=IF3
  64.        ENDIF
  65. C
  66. C
  67. C      RECHERCHE D'UNE 4EME FACETTE IF4
  68. C      --------------------------------
  69. C
  70.        IF4=IFACE3(JJ,IP1,JP2)
  71. C
  72.        IF (IF4.NE.0) THEN
  73. *  si if4 dans le mauvais sens rien a faire
  74.        if (isucc(if4,jj).ne.jp2) then
  75.         IF (IVERB.EQ.1) write (6,*) ' pyra1 face a l''envers if4 '
  76.         return
  77.        endif
  78.         IF (NFC(4,IF4).NE.0) THEN
  79.          CALL prism1(jp2,jj,IF2,IF4,IGAGNE)
  80.          RETURN
  81.         ENDIF
  82. *         WRITE(6,1020)IF4
  83. 1020      FORMAT(' ** IF4=',I4)
  84.         N4=IF4
  85.        ENDIF
  86. C
  87. C
  88. C      RECHERCHE D'UNE 5EME FACETTE IF5
  89. C      --------------------------------
  90. C
  91.        IF5=IFACE3(JP1,JP2,IP1)
  92. C
  93.        IF (IF5.NE.0) THEN
  94. *  si if5 dans le mauvais sens rien a faire
  95.        if (isucc(if5,jp2).ne.jp1) then
  96.         IF (IVERB.EQ.1) write (6,*) ' pyra1 face a l''envers if5 '
  97.         return
  98.        endif
  99.         IF (NFC(4,IF5).NE.0) GOTO 9000
  100. *         WRITE(6,1030)IF5
  101. 1030      FORMAT(' ** IF5=',I4)
  102.         N5=1
  103.        ENDIF
  104. C
  105. *   TEST LONGUEUR IP1 JP1 ET IP1 JP2
  106.        IF (N3.EQ.0.AND.N5.EQ.0) THEN
  107.         DNORM=(XYZ(1,IP1)-XYZ(1,JP1))**2
  108.      #       +(XYZ(2,IP1)-XYZ(2,JP1))**2
  109.      #       +(XYZ(3,IP1)-XYZ(3,JP1))**2
  110.         DTEST= tetrl*XYZ(4,IP1)*XYZ(4,JP1)
  111.         IF (DNORM.GT.DTEST) GOTO 250
  112.        ENDIF
  113.        IF (N4.EQ.0.AND.N5.EQ.0) THEN
  114.         DNORM=(XYZ(1,IP1)-XYZ(1,JP2))**2
  115.      #       +(XYZ(2,IP1)-XYZ(2,JP2))**2
  116.      #       +(XYZ(3,IP1)-XYZ(3,JP2))**2
  117.         DTEST= tetrl*XYZ(4,IP1)*XYZ(4,JP2)
  118.         IF (DNORM.GT.DTEST) GOTO 260
  119.        ENDIF
  120.        IF (IF3.EQ.0.AND.IF5.EQ.0) THEN
  121.           IF (DIAGO(IP1,JP1,diacri)) GOTO 9000
  122.        ENDIF
  123.        IF (IF4.EQ.0.AND.IF5.EQ.0) THEN
  124.           IF (DIAGO(IP1,JP2,diacri)) GOTO 9000
  125.        ENDIF
  126. C
  127.        IF (IF3.EQ.0) THEN
  128. C
  129. C      CREATION DE LA FACETTE IF3
  130. C      --------------------------
  131.        NFCMAX=NFCMAX+1
  132.        IF3=NFCMAX
  133.        ICTF=ICTF+1
  134. C
  135.        NFC(1,IF3)=II
  136.        NFC(2,IF3)=JP1
  137.        NFC(3,IF3)=IP1
  138.        NFC(4,IF3)=0
  139. C
  140.        ENDIF
  141. C
  142.        IF (IF4.EQ.0) THEN
  143. C
  144. C      CREATION DE LA FACETTE IF4
  145. C      --------------------------
  146.        NFCMAX=NFCMAX+1
  147.        IF4=NFCMAX
  148.        ICTF=ICTF+1
  149. C
  150.        NFC(1,IF4)=JJ
  151.        NFC(2,IF4)=IP1
  152.        NFC(3,IF4)=JP2
  153.        NFC(4,IF4)=0
  154. C
  155.        ENDIF
  156. C
  157.        IF (IF5.EQ.0) THEN
  158. C
  159. C      CREATION DE LA FACETTE IF5
  160. C      --------------------------
  161.        NFCMAX=NFCMAX+1
  162.        IF5=NFCMAX
  163.        ICTF=ICTF+1
  164. C
  165.        NFC(1,IF5)=JP1
  166.        NFC(2,IF5)=JP2
  167.        NFC(3,IF5)=IP1
  168.        NFC(4,IF5)=0
  169. C
  170.        ENDIF
  171. C
  172. C
  173. C      ON METS A JOUR LES FACETTES
  174. C      ---------------------------
  175.        CALL REPSUB(IF1)
  176.        CALL REPSUB(IF2)
  177.        CALL REPSUB(IF3)
  178.        CALL REPSUB(IF4)
  179.        CALL REPSUB(IF5)
  180. C
  181. C      LE VOLUME CREE EST-IL VALIDE ?
  182. C      ------------------------------
  183.        IF (N3.EQ.0) THEN
  184.          IF (.NOT.FACET(IF3))     GOTO 190
  185.        ENDIF
  186.        IF (N4.EQ.0) THEN
  187.          IF (.NOT.FACET(IF4))     GOTO 190
  188.        ENDIF
  189.        IF (N5.EQ.0) THEN
  190.          IF (.NOT.FACET(IF5))     GOTO 190
  191.        ENDIF
  192.        IF (.NOT.SOLPYR(IF2,IF1,IF3,IF4,IF5)) GOTO 190
  193. *  test des points milieux
  194.        if (n3.eq.0.and.n5.eq.0) then
  195.          DO 242 I=1,4
  196.          XYZ(I,NPTMAX+1)=(XYZ(4,JP1)*XYZ(I,IP1)+XYZ(4,IP1)*XYZ(I,JP1))/
  197.      #                        (XYZ(4,JP1)+XYZ(4,IP1))
  198.  242    CONTINUE
  199.         XYZ(4,NPTMAX+1)=SQRT(XYZ(4,IP1)*XYZ(4,JP1))
  200.         CALL DIST(nptmax+1,nptaux,GL,IOK,II,JJ,IP1,JP1,JP2,0,0,0,0,0)
  201.          IF (IOK.EQ.0) then
  202.           IF (IVERB.EQ.1) write (6,*) ' pyra1 DIST-1  echoue'
  203.           goto 190
  204.          endif
  205.          IF (gl.lt.xyz(4,nptmax+1)/4) then
  206.           IF (IVERB.EQ.1) write (6,*) ' pyra1 DIST-1-GL echoue'
  207.           goto 190
  208.          endif
  209.        endif
  210.        if (n4.eq.0.and.n5.eq.0) then
  211.          DO 243 I=1,4
  212.          XYZ(I,NPTMAX+1)=(XYZ(4,JP2)*XYZ(I,IP1)+XYZ(4,IP1)*XYZ(I,JP2))/
  213.      #                        (XYZ(4,JP2)+XYZ(4,IP1))
  214.  243    CONTINUE
  215.         XYZ(4,NPTMAX+1)=SQRT(XYZ(4,IP1)*XYZ(4,JP2))
  216.         CALL DIST(nptmax+1,nptaux,GL,IOK,II,JJ,IP1,JP1,JP2,0,0,0,0,0)
  217.          IF (IOK.EQ.0) then
  218.           IF (IVERB.EQ.1) write (6,*) ' pyra1 DIST-2  echoue'
  219.           goto 190
  220.          endif
  221.          IF (gl.lt.xyz(4,nptmax+1)/4) then
  222.           IF (IVERB.EQ.1) write (6,*) ' pyra1 DIST-2-GL echoue'
  223.           goto 190
  224.          endif
  225.        endif
  226. *
  227. C
  228. C      LE VOLUME CREE EST VALIDE
  229. C      -------------------------
  230. C      MEMORISATION DU VOLUME OBTENU
  231. C      -----------------------------
  232.        NVOL=NVOL+1
  233.        IF (NFV(1,IF1).EQ.0) NFV(1,IF1)=NVOL
  234.        IF (NFV(1,IF1).NE.NVOL) NFV(2,IF1)=NVOL
  235.        IF (NFV(1,IF2).EQ.0) NFV(1,IF2)=NVOL
  236.        IF (NFV(1,IF2).NE.NVOL) NFV(2,IF2)=NVOL
  237.        IF (NFV(1,IF3).EQ.0) NFV(1,IF3)=NVOL
  238.        IF (NFV(1,IF3).NE.NVOL) NFV(2,IF3)=NVOL
  239.        IF (NFV(1,IF4).EQ.0) NFV(1,IF4)=NVOL
  240.        IF (NFV(1,IF4).NE.NVOL) NFV(2,IF4)=NVOL
  241.        IF (NFV(1,IF5).EQ.0) NFV(1,IF5)=NVOL
  242.        IF (NFV(1,IF5).NE.NVOL) NFV(2,IF5)=NVOL
  243.        IVOL(9,NVOL)=35
  244.        DO 170 I=1,4
  245.           IVOL(I,NVOL)=NFC(I,IF2)
  246. 170    CONTINUE
  247.        IVOL(5,NVOL)=IP1
  248. C
  249. *      WRITE(6,1100)NVOL,(IVOL(I,NVOL),I=1,9)
  250. *1100   FORMAT(I3,4X,14I4)
  251.        if (iimpi.eq.1) write (6,1100) nfacet,(ivol(i,nvol),i=1,5)
  252. 1100   FORMAT(' PYRA1 facettes ',i5,' pyr5 ',5i5)
  253. C
  254. *       DO 180 J=1,NPTMAX
  255. *          WRITE(6,1110)J,(NPF(I,J),I=1,40)
  256. *1110      FORMAT(I4,4X,40I3)
  257. *180    CONTINUE
  258. C
  259. C
  260.        IGAGNE=1
  261. C
  262.        RETURN
  263. C
  264. 190    CONTINUE
  265. C
  266. C      LE VOLUME CREE EST INVALIDE: IL FAUT DONC DETRUIRE LES FACETTES
  267. C      CREES. --------------------------------------------------------
  268.        CALL REPSUB(IF1)
  269.        CALL REPSUB(IF2)
  270.        CALL REPSUB(IF3)
  271.        CALL REPSUB(IF4)
  272.        CALL REPSUB(IF5)
  273. C
  274.        NFCMAX=NFCMAX-ICTF
  275. C
  276.        GOTO 9000
  277. C
  278.  9000  CONTINUE
  279.        IF (IBOUT.EQ.1) RETURN
  280.        IF (N3.NE.0) CALL COMBL3(II,IF1,IF2,N3,IGAGNE)
  281.         IF (IGAGNE.EQ.1) RETURN
  282.        IF (N4.NE.0) CALL COMBL3(JJ,IF2,IF1,N4,IGAGNE)
  283.        RETURN
  284.  250   CONTINUE
  285.  260   CONTINUE
  286. *  CREATION POINT MILIEU
  287.        NPTMAX=NPTMAX+1
  288.         XYZ(4,NPTMAX)=(XYZ(4,IP1)+XYZ(4,JP1)+XYZ(4,JP2))/3.
  289. *  deplacement du point pour l'eloigner de ii jj
  290.        xn1=(xyz(2,jj)-xyz(2,ii))*(xyz(3,ip1)-xyz(3,ii))-
  291.      >     (xyz(3,jj)-xyz(3,ii))*(xyz(2,ip1)-xyz(2,ii))
  292.        yn1=(xyz(3,jj)-xyz(3,ii))*(xyz(1,ip1)-xyz(1,ii))-
  293.      >     (xyz(1,jj)-xyz(1,ii))*(xyz(3,ip1)-xyz(3,ii))
  294.        zn1=(xyz(1,jj)-xyz(1,ii))*(xyz(2,ip1)-xyz(2,ii))-
  295.      >     (xyz(2,jj)-xyz(2,ii))*(xyz(1,ip1)-xyz(1,ii))
  296. *      scal=xn1*(xyz(1,jp1)-xyz(1,ii))+xn2*(xyz(2,jp1)-xyz(2,ii))+
  297. *    >      xn3*(xyz(3,jp1)-xyz(3,ii))
  298. *       write (6,*) ' dnas tetra scal ',scal
  299. *       write (6,*) ' ii ',(XYZ(i,ii),i=1,4)
  300. *       write (6,*) ' jj ',(XYZ(i,jj),i=1,4)
  301. *       write (6,*) ' ip ',(XYZ(i,ip),i=1,4)
  302. *       write (6,*) ' jp ',(XYZ(i,jp),i=1,4)
  303. *       write (6,*) ' xn ',xn1,yn1,zn1
  304.        sn1=sqrt(xn1**2+yn1**2+zn1**2)
  305.        xn1=xn1/sn1
  306.        yn1=yn1/sn1
  307.        zn1=zn1/sn1
  308.        xn2=((xyz(2,jp1)+xyz(2,jp2))/2-xyz(2,ii))*(xyz(3,jj)-xyz(3,ii))-
  309.      >     ((xyz(3,jp1)+xyz(3,jp2))/2-xyz(3,ii))*(xyz(2,jj)-xyz(2,ii))
  310.        yn2=((xyz(3,jp1)+xyz(3,jp2))/2-xyz(3,ii))*(xyz(1,jj)-xyz(1,ii))-
  311.      >     ((xyz(1,jp1)+xyz(1,jp2))/2-xyz(1,ii))*(xyz(3,jj)-xyz(3,ii))
  312.        zn2=((xyz(1,jp1)+xyz(1,jp2))/2-xyz(1,ii))*(xyz(2,jj)-xyz(2,ii))-
  313.      >     ((xyz(2,jp1)+xyz(2,jp2))/2-xyz(2,ii))*(xyz(1,jj)-xyz(1,ii))
  314.        sn2=sqrt(xn2**2+yn2**2+zn2**2)
  315.        xn2=xn2/sn2
  316.        yn2=yn2/sn2
  317.        zn2=zn2/sn2
  318.        xn=(xn1+xn2)/2
  319.        yn=(yn1+yn2)/2
  320.        zn=(zn1+zn2)/2
  321.        sn=sqrt(xn**2+yn**2+zn**2)
  322.        xn=xn/sn
  323.        yn=yn/sn
  324.        zn=zn/sn
  325. *      xmil=(xyz(1,ii)+xyz(1,jj))/2
  326. *      ymil=(xyz(2,ii)+xyz(2,jj))/2
  327. *      zmil=(xyz(3,ii)+xyz(3,jj))/2
  328. *
  329.        xv=xyz(1,jj)-xyz(1,ii)
  330.        yv=xyz(2,jj)-xyz(2,ii)
  331.        zv=xyz(3,jj)-xyz(3,ii)
  332.        sv=sqrt(xv**2+yv**2+zv**2)
  333.        xv=xv/sv
  334.        yv=yv/sv
  335.        zv=zv/sv
  336.        xli=xv*(xyz(1,ip1)-xyz(1,ii))+yv*(xyz(2,ip1)-xyz(2,ii))+
  337.      >     zv*(xyz(3,ip1)-xyz(3,ii))
  338.        xlj1=xv*(xyz(1,jp1)-xyz(1,ii))+yv*(xyz(2,jp1)-xyz(2,ii))+
  339.      >      zv*(xyz(3,jp1)-xyz(3,ii))
  340.        xlj2=xv*(xyz(1,jp2)-xyz(1,ii))+yv*(xyz(2,jp2)-xyz(2,ii))+
  341.      >      zv*(xyz(3,jp2)-xyz(3,ii))
  342.        xl=(xli+xlj1+xlj2+2*sv+2*0)/7
  343.        xl=0.5*sv
  344.        xmil=xyz(1,ii)+xl*xv
  345.        ymil=xyz(2,ii)+xl*yv
  346.        zmil=xyz(3,ii)+xl*zv
  347.        expf = xyz(4,nptmax)
  348.        xyz(1,nptmax)=xmil+xn*expf*expfac
  349.        xyz(2,nptmax)=ymil+yn*expf*expfac
  350.        xyz(3,nptmax)=zmil+zn*expf*expfac
  351. *       write (6,*) ' pyra1 creation de 2 elements et pt ',nptmax
  352. *        write (6,*) ' coordonnees ',(XYZ(i,nptmax),i=1,4)
  353. *        write (6,*) ' coordonnees ',(XYZ(i,ip),i=1,4)
  354. *        write (6,*) ' coordonnees ',(XYZ(i,jp),i=1,4)
  355. *        write (6,*) ' coordonnees ',xmil,ymil,zmil
  356. *   CREATION DES ELEMENTS
  357.        IPTT=NPTMAX
  358.        CALL DIST(iptt,nptaux,GL,IOK,ii,jj,ip1,jp1,jp2,0,0,0,0,0)
  359.        IF (IOK.EQ.0) THEN
  360.        NPTMAX=nptini
  361.        IF (IVERB.EQ.1) WRITE (6,*) ' pyra1 DIST ',nptaux
  362. *       if (nptaux.eq.0) goto 9000
  363.        return
  364.        iptt=nptaux
  365.        ENDIF
  366.        IF (gl.lt.xyz(4,iptt)/4) then
  367.        IF (IVERB.EQ.1) write (6,*) 'pyra1 GL-1'
  368.         nptmax=nptini
  369.         return
  370.        endif
  371.  253   continue
  372.        IF (.NOT.IN2(ii,IPTT,nfcini).or..NOT.IN2(jj,IPTT,nfcini)) THEN
  373.         NPTMAX=nptini
  374.         goto 9000
  375.        ENDIF
  376. *     recherche existence de la face
  377.        IF3=IFACE3(ii,iptt,ip1)
  378.        IF (IF3.ne.0.AND.IVERB.EQ.1) 
  379.      &       write (6,*) ' pyra1 facette assimilee'
  380.        IF (IF3.eq.0) THEN
  381.         NFCMAX=NFCMAX+1
  382.         IF3=NFCMAX
  383.         NFC(1,IF3)=II
  384.         NFC(2,IF3)=iptt
  385.         NFC(3,IF3)=IP1
  386.         NFC(4,IF3)=0
  387.        elseif (NFC(4,if3).ne.0.or.ipred(if3,ii).ne.iptt) then
  388.          IF (IVERB.EQ.1) write(6,*) ' pyra1 probleme facette if3 ',if3
  389.          nptmax=nptini
  390.          nfcmax=nfcini
  391.          goto 9000
  392.        endif
  393. *     recherche existence de la face
  394.        IF4=IFACE3(ii,jp1,iptt)
  395.        IF (IF4.ne.0.AND.IVERB.EQ.1) 
  396.      &       write (6,*) ' pyra1 facette assimilee'
  397.        IF (IF4.eq.0) THEN
  398.        NFCMAX=NFCMAX+1
  399.        IF4=NFCMAX
  400.        NFC(1,IF4)=II
  401.        NFC(2,IF4)=JP1
  402.        NFC(3,IF4)=iptt
  403.        NFC(4,IF4)=0
  404.        elseif (NFC(4,if4).ne.0.or.ipred(if4,ii).ne.jp1) then
  405.          IF (IVERB.EQ.1) write(6,*) ' pyra1 probleme facette if4 ',if4
  406.          nptmax=nptini
  407.          nfcmax=nfcini
  408.          goto 9000
  409.        endif
  410. *     recherche existence de la face
  411.        IF5=IFACE3(jp1,jp2,iptt)
  412.        IF (IF5.ne.0.AND.IVERB.EQ.1) 
  413.      &       write (6,*) ' pyra1 facette assimilee'
  414.        IF (IF5.eq.0) THEN
  415.        NFCMAX=NFCMAX+1
  416.        IF5=NFCMAX
  417.        NFC(1,IF5)=JP1
  418.        NFC(2,IF5)=JP2
  419.        NFC(3,IF5)=iptt
  420.        NFC(4,IF5)=0
  421.        elseif (NFC(4,if5).ne.0.or.ipred(if5,jp1).ne.jp2) then
  422.          IF (IVERB.EQ.1) write(6,*) ' pyra1 probleme facette if5 ',if5
  423.          nptmax=nptini
  424.          nfcmax=nfcini
  425.          goto 9000
  426.        endif
  427. *     recherche existence de la face
  428.        IF6=IFACE3(jp2,jj,iptt)
  429.        IF (IF6.ne.0.AND.IVERB.EQ.1) 
  430.      &       write (6,*) ' pyra1 facette assimilee'
  431.        IF (IF6.eq.0) THEN
  432.        NFCMAX=NFCMAX+1
  433.        IF6=NFCMAX
  434.        NFC(1,IF6)=JP2
  435.        NFC(2,IF6)=JJ
  436.        NFC(3,IF6)=iptt
  437.        NFC(4,IF6)=0
  438.        elseif (NFC(4,if6).ne.0.or.ipred(if6,jp2).ne.jj) then
  439.          IF (IVERB.EQ.1) write(6,*) ' pyra1 probleme facette if6 ',if6
  440.          nptmax=nptini
  441.          nfcmax=nfcini
  442.          goto 9000
  443.        endif
  444. *     recherche existence de la face
  445.        IF7=IFACE3(jj,ip1,iptt)
  446.        IF (IF7.ne.0.AND.IVERB.EQ.1) 
  447.      &       write (6,*) ' pyra1 facette assimilee'
  448.        IF (IF7.eq.0) THEN
  449.        NFCMAX=NFCMAX+1
  450.        IF7=NFCMAX
  451.        NFC(1,IF7)=JJ
  452.        NFC(2,IF7)=IP1
  453.        NFC(3,IF7)=iptt
  454.        NFC(4,IF7)=0
  455.        elseif (NFC(4,if7).ne.0.or.ipred(if7,jj).ne.ip1) then
  456.          IF (IVERB.EQ.1) write(6,*) ' pyra1 probleme facette if7 ',if7
  457.          nptmax=nptini
  458.          nfcmax=nfcini
  459.          goto 9000
  460.        endif
  461. *  creation facette commune (necessaire pour faire les verification)
  462.        IF8=IFACE3(ii,jj,iptt)
  463.        IF (IF8.ne.0.AND.IVERB.EQ.1) 
  464.      &       write(6,*)' pyra1 facette if8 existe deja => echec'
  465.        IF (IF8.ne.0) THEN
  466.          nptmax=nptini
  467.          nfcmax=nfcini
  468.          goto 9000
  469.        endif
  470.        NFCMAX=NFCMAX+1
  471.        IF8=NFCMAX
  472.        NFC(1,IF8)=ii
  473.        NFC(2,IF8)=jj
  474.        NFC(3,IF8)=iptt
  475.        NFC(4,IF8)=0
  476. *  si necessaire verification diago
  477. *      if (nptini.eq.nptmax) then
  478.          IF (DIAGO(iptt,ii,diacri)) GOTO 275
  479.          IF (DIAGO(iptt,jj,diacri)) GOTO 275
  480.          IF (DIAGO(iptt,ip1,diacri)) GOTO 275
  481.          IF (DIAGO(iptt,jp1,diacri)) GOTO 275
  482.          IF (DIAGO(iptt,jp2,diacri)) GOTO 275
  483.          goto 276
  484.  275     continue
  485.          nptmax=nptini
  486.          nfcmax=nfcini
  487.          goto 9000
  488.  276     continue
  489. *      endif
  490. C
  491.        CALL REPSUB(IF1)
  492.        CALL REPSUB(IF3)
  493.        CALL REPSUB(IF7)
  494.        CALL REPSUB(IF8)
  495. *  verification du premier element element
  496.        IF (.NOT.SOLTET(IF1,IF3,IF7,IF8,ipin)) then
  497.          IF (IVERB.EQ.1) write (6,*) 'pyra1 soltet invalide'
  498.          GOTO 160
  499.        endif
  500.          IF (.NOT.FACET(IF3))     then
  501.            IF (IVERB.EQ.1) write(6,*) ' pyra1 facet if3 invalide'
  502.            GOTO 160
  503.          ENDIF
  504.          IF (.NOT.FACET(IF7))     then
  505.            IF (IVERB.EQ.1) write(6,*) ' pyra1 facet if7 invalide'
  506.            GOTO 160
  507.          ENDIF
  508.        CALL REPSUB(IF2)
  509.        CALL REPSUB(IF4)
  510.        CALL REPSUB(IF5)
  511.        CALL REPSUB(IF6)
  512.        CALL REPSUB(IF8)
  513. *  verification du deuxieme element element
  514.        IF (.NOT.SOLPYR(IF2,IF4,IF5,IF6,IF8)) then
  515.          IF (IVERB.EQ.1) write (6,*) 'pyra1 solpyr invalide'
  516.          GOTO 165
  517.        endif
  518.          IF (.NOT.FACET(IF4))     then
  519.            IF (IVERB.EQ.1) write(6,*) ' pyra1 facet if4 invalide'
  520.            GOTO 165
  521.          ENDIF
  522.          IF (.NOT.FACET(IF5))     then
  523.            IF (IVERB.EQ.1) write(6,*) ' pyra1 facet if5 invalide'
  524.            GOTO 165
  525.          ENDIF
  526.          IF (.NOT.FACET(IF6))     then
  527.            IF (IVERB.EQ.1) write(6,*) ' pyra1 facet if6 invalide'
  528.            GOTO 165
  529.          ENDIF
  530. *  OK pour creation elements
  531.        NVOL=NVOL+1
  532.        IF (NFV(1,IF1).EQ.0) NFV(1,IF1)=NVOL
  533.        IF (NFV(1,IF1).NE.NVOL) NFV(2,IF1)=NVOL
  534.        IF (NFV(1,IF3).EQ.0) NFV(1,IF3)=NVOL
  535.        IF (NFV(1,IF3).NE.NVOL) NFV(2,IF3)=NVOL
  536.        IF (NFV(1,IF4).EQ.0) NFV(1,IF4)=NVOL
  537.        IF (NFV(1,IF4).NE.NVOL) NFV(2,IF4)=NVOL
  538.        IF (NFV(1,IF5).EQ.0) NFV(1,IF5)=NVOL
  539.        IF (NFV(1,IF5).NE.NVOL) NFV(2,IF5)=NVOL
  540.        IVOL(9,NVOL)=35
  541.        DO 280 I=1,4
  542.           IVOL(I,NVOL)=NFC(I,IF2)
  543. 280    CONTINUE
  544.        IVOL(5,NVOL)=iptt
  545.        if (iimpi.eq.1) write (6,1102) nfacet,(ivol(i,nvol),i=1,5)
  546. 1102   FORMAT(' PYRA1-1 facettes ',i5,' pyr5 ',8i5)
  547.        NVOL=NVOL+1
  548.        IVOL(9,NVOL)=25
  549.        IF (NFV(1,IF2).EQ.0) NFV(1,IF2)=NVOL
  550.        IF (NFV(1,IF2).NE.NVOL) NFV(2,IF2)=NVOL
  551.        IF (NFV(1,IF6).EQ.0) NFV(1,IF6)=NVOL
  552.        IF (NFV(1,IF6).NE.NVOL) NFV(2,IF6)=NVOL
  553.        IF (NFV(1,IF7).EQ.0) NFV(1,IF7)=NVOL
  554.        IF (NFV(1,IF7).NE.NVOL) NFV(2,IF7)=NVOL
  555.        DO 282 I=1,3
  556.           IVOL(I,NVOL)=NFC(I,IF1)
  557. 282    CONTINUE
  558.        IVOL(4,NVOL)=iptt
  559.        if (iimpi.eq.1) write (6,1101) nfacet,(ivol(i,nvol),i=1,4)
  560. 1101   FORMAT(' PYRA1-2 facettes ',i5,' tet4 ',8i5)
  561. *      write (6,*) ' pyra1 2 elements fabriques '
  562. *      write (6,*) ' liste des facettes '
  563. *      DO 444 I=1,NFCMAX
  564. *       IF (IFAT(I).EQ.1) GOTO 444
  565. *       WRITE (6,*)  I,NFC(1,I),NFC(2,I),NFC(3,I),NFC(4,I)
  566. *444  CONTINUE
  567.        IGAGNE=1
  568.        RETURN
  569. 165    continue
  570.        CALL REPSUB(IF8)
  571.        CALL REPSUB(IF6)
  572.        CALL REPSUB(IF5)
  573.        CALL REPSUB(IF4)
  574.        CALL REPSUB(IF2)
  575. 160    continue
  576.        CALL REPSUB(IF8)
  577.        CALL REPSUB(IF7)
  578.        CALL REPSUB(IF3)
  579.        CALL REPSUB(IF1)
  580.          nptmax=nptini
  581.          nfcmax=nfcini
  582.        goto 9000
  583.  
  584.        END
  585.  
  586.  
  587.  
  588.  
  589.  

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