Télécharger la plaquette Cast3M


fr en

Télécharger pyra3.eso

Retour à la liste

Numérotation des lignes : 

pyra3

  1. C PYRA3     SOURCE    JC220346  16/11/29    21:15:31     9221           
  2. C---------------------------------------------------------------------|
  3. C                                                                     |
  4.        SUBROUTINE PYRA3(II,JJ,IF1,IF2,IGAGNE)
  5. C                                                                     |
  6. C      CETTE SUBROUTINE TENTE DE CREER DEUX PYRAMIDES  A PARTIR       |
  7. C      DES QUADRANGLES IF1 et 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(' ----->>> PYRA3 <<<-----')
  23. C
  24.        nptini=nptmax
  25.        nfcini=nfcmax
  26.        ICTF=0
  27.        ICTV=0
  28.        IP1=IPRED(IF1,II)
  29.        IP2=IPRED(IF1,IP1)
  30.        JP1=ISUCC(IF2,II)
  31.        JP2=ISUCC(IF2,JP1)
  32. *  CREATION POINT MILIEU
  33.        NPTMAX=NPTMAX+1
  34.         XYZ(4,NPTMAX)=(XYZ(4,IP1)+XYZ(4,IP2)+XYZ(4,JP1)+XYZ(4,JP2))/4.
  35. *  deplacement du point pour l'eloigner de ii jj
  36.        xn1=(xyz(2,jj)-xyz(2,ii))*((xyz(3,ip1)+xyz(3,ip2))/2-xyz(3,ii))-
  37.      >     (xyz(3,jj)-xyz(3,ii))*((xyz(2,ip1)+xyz(2,ip2))/2-xyz(2,ii))
  38.        yn1=(xyz(3,jj)-xyz(3,ii))*((xyz(1,ip1)+xyz(1,ip2))/2-xyz(1,ii))-
  39.      >     (xyz(1,jj)-xyz(1,ii))*((xyz(3,ip1)+xyz(3,ip2))/2-xyz(3,ii))
  40.        zn1=(xyz(1,jj)-xyz(1,ii))*((xyz(2,ip1)+xyz(2,ip2))/2-xyz(2,ii))-
  41.      >     (xyz(2,jj)-xyz(2,ii))*((xyz(1,ip1)+xyz(1,ip2))/2-xyz(1,ii))
  42.        sn1=sqrt(xn1**2+yn1**2+zn1**2)
  43.        xn1=xn1/sn1
  44.        yn1=yn1/sn1
  45.        zn1=zn1/sn1
  46.        xn2=((xyz(2,jp1)+xyz(2,jp2))/2-xyz(2,ii))*(xyz(3,jj)-xyz(3,ii))-
  47.      >     ((xyz(3,jp1)+xyz(3,jp2))/2-xyz(3,ii))*(xyz(2,jj)-xyz(2,ii))
  48.        yn2=((xyz(3,jp1)+xyz(3,jp2))/2-xyz(3,ii))*(xyz(1,jj)-xyz(1,ii))-
  49.      >     ((xyz(1,jp1)+xyz(1,jp2))/2-xyz(1,ii))*(xyz(3,jj)-xyz(3,ii))
  50.        zn2=((xyz(1,jp1)+xyz(1,jp2))/2-xyz(1,ii))*(xyz(2,jj)-xyz(2,ii))-
  51.      >     ((xyz(2,jp1)+xyz(2,jp2))/2-xyz(2,ii))*(xyz(1,jj)-xyz(1,ii))
  52.        sn2=sqrt(xn2**2+yn2**2+zn2**2)
  53.        xn2=xn2/sn2
  54.        yn2=yn2/sn2
  55.        zn2=zn2/sn2
  56.        xn=(xn1+xn2)/2
  57.        yn=(yn1+yn2)/2
  58.        zn=(zn1+zn2)/2
  59.        sn=sqrt(xn**2+yn**2+zn**2)
  60.        xn=xn/sn
  61.        yn=yn/sn
  62.        zn=zn/sn
  63. *      xmil=(xyz(1,ii)+xyz(1,jj))/2
  64. *      ymil=(xyz(2,ii)+xyz(2,jj))/2
  65. *      zmil=(xyz(3,ii)+xyz(3,jj))/2
  66. *
  67.        xv=xyz(1,jj)-xyz(1,ii)
  68.        yv=xyz(2,jj)-xyz(2,ii)
  69.        zv=xyz(3,jj)-xyz(3,ii)
  70.        sv=sqrt(xv**2+yv**2+zv**2)
  71.        xv=xv/sv
  72.        yv=yv/sv
  73.        zv=zv/sv
  74.        xli1=xv*(xyz(1,ip1)-xyz(1,ii))+yv*(xyz(2,ip1)-xyz(2,ii))+
  75.      >      zv*(xyz(3,ip1)-xyz(3,ii))
  76.        xli2=xv*(xyz(1,ip2)-xyz(1,ii))+yv*(xyz(2,ip2)-xyz(2,ii))+
  77.      >      zv*(xyz(3,ip2)-xyz(3,ii))
  78.        xlj1=xv*(xyz(1,jp1)-xyz(1,ii))+yv*(xyz(2,jp1)-xyz(2,ii))+
  79.      >      zv*(xyz(3,jp1)-xyz(3,ii))
  80.        xlj2=xv*(xyz(1,jp2)-xyz(1,ii))+yv*(xyz(2,jp2)-xyz(2,ii))+
  81.      >      zv*(xyz(3,jp2)-xyz(3,ii))
  82.        xl=(xli1+xli2+xlj1+xlj2+2*sv+2*0)/8
  83.        xl=0.5*sv
  84.        xmil=xyz(1,ii)+xl*xv
  85.        ymil=xyz(2,ii)+xl*yv
  86.        zmil=xyz(3,ii)+xl*zv
  87.        expf = xyz(4,nptmax)
  88.        xyz(1,nptmax)=xmil+xn*expf*expfac
  89.        xyz(2,nptmax)=ymil+yn*expf*expfac
  90.        xyz(3,nptmax)=zmil+zn*expf*expfac
  91. *       write (6,*) ' pyra3 creation de 2 elements et pt ',nptmax
  92. *        write (6,*) (xyz(i,ii),i=1,4)
  93. *        write (6,*) (xyz(i,jj),i=1,4)
  94. *        write (6,*) (xyz(i,ip1),i=1,4)
  95. *        write (6,*) (xyz(i,ip2),i=1,4)
  96. *        write (6,*) (xyz(i,jp1),i=1,4)
  97. *        write (6,*) (xyz(i,jp2),i=1,4)
  98. *        write (6,*) (xyz(i,nptmax),i=1,4)
  99. *   CREATION DES ELEMENTS
  100.        IPTT=NPTMAX
  101.        CALL DIST(iptt,nptaux,GL,IOK,ii,jj,ip1,ip2,jp1,jp2,0,0,0,0)
  102.        IF (IOK.EQ.0) THEN
  103.        NPTMAX=nptini
  104.        IF (IVERB.EQ.1) WRITE (6,*) ' pyra3 DIST ',nptaux
  105.        return
  106.        ENDIF
  107.        IF (gl.lt.xyz(4,iptt)/4) then
  108.        IF (IVERB.EQ.1) write (6,*) 'pyra3 GL-1'
  109.         nptmax=nptini
  110.         return
  111.        endif
  112.        IF (.NOT.IN2(ii,IPTT,nfcini).or..NOT.IN2(jj,IPTT,nfcini)) THEN
  113.         IF (IVERB.EQ.1) write (6,*) ' in2 echec '
  114.         NPTMAX=nptini
  115.         return
  116.        ENDIF
  117. *     creations des faces
  118.         NFCMAX=NFCMAX+1
  119.         IF3=NFCMAX
  120.         NFC(1,IF3)=II
  121.         NFC(2,IF3)=iptt
  122.         NFC(3,IF3)=IP1
  123.         NFC(4,IF3)=0
  124. *
  125.         NFCMAX=NFCMAX+1
  126.         IF4=NFCMAX
  127.         NFC(1,IF4)=IP1
  128.         NFC(2,IF4)=IPTT
  129.         NFC(3,IF4)=IP2
  130.         NFC(4,IF4)=0
  131. *
  132.         NFCMAX=NFCMAX+1
  133.         IF5=NFCMAX
  134.         NFC(1,IF5)=IP2
  135.         NFC(2,IF5)=IPTT
  136.         NFC(3,IF5)=JJ
  137.         NFC(4,IF5)=0
  138. *   la face commune
  139.         NFCMAX=NFCMAX+1
  140.         IF6=NFCMAX
  141.         NFC(1,IF6)=JJ
  142.         NFC(2,IF6)=IPTT
  143.         NFC(3,IF6)=II
  144.         NFC(4,IF6)=0
  145. *
  146.         NFCMAX=NFCMAX+1
  147.         IF7=NFCMAX
  148.         NFC(1,IF7)=JJ
  149.         NFC(2,IF7)=iptt
  150.         NFC(3,IF7)=jp2
  151.         NFC(4,IF7)=0
  152. *
  153.         NFCMAX=NFCMAX+1
  154.         IF8=NFCMAX
  155.         NFC(1,IF8)=jp2
  156.         NFC(2,IF8)=iptt
  157.         NFC(3,IF8)=jp1
  158.         NFC(4,IF8)=0
  159. *
  160.         NFCMAX=NFCMAX+1
  161.         IF9=NFCMAX
  162.         NFC(1,IF9)=jp1
  163.         NFC(2,IF9)=iptt
  164.         NFC(3,IF9)=II
  165.         NFC(4,IF9)=0
  166. *  si necessaire verification diago
  167.          IF (DIAGO(iptt,ii,diacri)) GOTO 275
  168.          IF (DIAGO(iptt,jj,diacri)) GOTO 275
  169.          IF (DIAGO(iptt,ip1,diacri)) GOTO 275
  170.          IF (DIAGO(iptt,ip2,diacri)) GOTO 275
  171.          IF (DIAGO(iptt,jp1,diacri)) GOTO 275
  172.          IF (DIAGO(iptt,jp2,diacri)) GOTO 275
  173.          goto 276
  174.  275     continue
  175.          nptmax=nptini
  176.          nfcmax=nfcini
  177.         IF (IVERB.EQ.1) write (6,*) ' pyra3 echec diago'
  178.          return
  179.  276     continue
  180. C
  181.        CALL REPSUB(IF1)
  182.        CALL REPSUB(IF3)
  183.        CALL REPSUB(IF4)
  184.        CALL REPSUB(IF5)
  185.        CALL REPSUB(IF6)
  186. *  verification du premier element element
  187.        IF (.NOT.SOLPYR(IF1,IF3,IF4,IF5,IF6)) then
  188.          IF (IVERB.EQ.1) write (6,*) 'pyra3-1 solpyr invalide'
  189.          GOTO 160
  190.        endif
  191.          IF (.NOT.FACET(IF3))     then
  192.            IF (IVERB.EQ.1) write(6,*) ' pyra3 facet if3 invalide'
  193.            GOTO 160
  194.          ENDIF
  195.          IF (.NOT.FACET(IF4))     then
  196.            IF (IVERB.EQ.1) write(6,*) ' pyra3 facet if4 invalide'
  197.            GOTO 160
  198.          ENDIF
  199.          IF (.NOT.FACET(IF5))     then
  200.            IF (IVERB.EQ.1) write(6,*) ' pyra3 facet if5 invalide'
  201.            GOTO 160
  202.          ENDIF
  203.        CALL REPSUB(IF2)
  204.        CALL REPSUB(IF6)
  205.        CALL REPSUB(IF7)
  206.        CALL REPSUB(IF8)
  207.        CALL REPSUB(IF9)
  208. *  verification du deuxieme element element
  209.        IF (.NOT.SOLPYR(IF2,IF6,IF7,IF8,IF9)) then
  210.          IF (IVERB.EQ.1) write (6,*) 'pyra3-2 solpyr invalide'
  211.          GOTO 165
  212.        endif
  213.          IF (.NOT.FACET(IF7))     then
  214.            IF (IVERB.EQ.1) write(6,*) ' pyra3 facet if7 invalide'
  215.            GOTO 165
  216.          ENDIF
  217.          IF (.NOT.FACET(IF8))     then
  218.            IF (IVERB.EQ.1) write(6,*) ' pyra1 facet if8 invalide'
  219.            GOTO 165
  220.          ENDIF
  221.          IF (.NOT.FACET(IF9))     then
  222.            IF (IVERB.EQ.1) write(6,*) ' pyra1 facet if9 invalide'
  223.            GOTO 165
  224.          ENDIF
  225. *  OK pour creation elements
  226.        NVOL=NVOL+1
  227.        IF (NFV(1,IF1).EQ.0) NFV(1,IF1)=NVOL
  228.        IF (NFV(1,IF1).NE.NVOL) NFV(2,IF1)=NVOL
  229.        IF (NFV(1,IF3).EQ.0) NFV(1,IF3)=NVOL
  230.        IF (NFV(1,IF3).NE.NVOL) NFV(2,IF3)=NVOL
  231.        IF (NFV(1,IF4).EQ.0) NFV(1,IF4)=NVOL
  232.        IF (NFV(1,IF4).NE.NVOL) NFV(2,IF4)=NVOL
  233.        IF (NFV(1,IF5).EQ.0) NFV(1,IF5)=NVOL
  234.        IF (NFV(1,IF5).NE.NVOL) NFV(2,IF5)=NVOL
  235.        IF (NFV(1,IF6).EQ.0) NFV(1,IF6)=NVOL
  236.        IF (NFV(1,IF6).NE.NVOL) NFV(2,IF6)=NVOL
  237.        IVOL(9,NVOL)=35
  238.        DO 280 I=1,4
  239.           IVOL(I,NVOL)=NFC(I,IF1)
  240. 280    CONTINUE
  241.        IVOL(5,NVOL)=iptt
  242.        if (iimpi.eq.1) write (6,1102) nfacet,(ivol(i,nvol),i=1,5)
  243. 1102   FORMAT(' PYRA3-1 facettes ',i5,' pyr5 ',8i5)
  244.        NVOL=NVOL+1
  245.        IVOL(9,NVOL)=35
  246.        IF (NFV(1,IF2).EQ.0) NFV(1,IF2)=NVOL
  247.        IF (NFV(1,IF2).NE.NVOL) NFV(2,IF2)=NVOL
  248.        IF (NFV(1,IF6).EQ.0) NFV(1,IF6)=NVOL
  249.        IF (NFV(1,IF6).NE.NVOL) NFV(2,IF6)=NVOL
  250.        IF (NFV(1,IF7).EQ.0) NFV(1,IF7)=NVOL
  251.        IF (NFV(1,IF7).NE.NVOL) NFV(2,IF7)=NVOL
  252.        IF (NFV(1,IF8).EQ.0) NFV(1,IF8)=NVOL
  253.        IF (NFV(1,IF8).NE.NVOL) NFV(2,IF8)=NVOL
  254.        IF (NFV(1,IF9).EQ.0) NFV(1,IF9)=NVOL
  255.        IF (NFV(1,IF9).NE.NVOL) NFV(2,IF9)=NVOL
  256.        DO 282 I=1,4
  257.           IVOL(I,NVOL)=NFC(I,IF2)
  258. 282    CONTINUE
  259.        IVOL(5,NVOL)=iptt
  260.        if (iimpi.eq.1) write (6,1101) nfacet,(ivol(i,nvol),i=1,5)
  261. 1101   FORMAT(' PYRA3-2 facettes ',i5,' pyr5 ',8i5)
  262.        IGAGNE=1
  263.        RETURN
  264. 165    continue
  265.        CALL REPSUB(IF9)
  266.        CALL REPSUB(IF8)
  267.        CALL REPSUB(IF7)
  268.        CALL REPSUB(IF6)
  269.        CALL REPSUB(IF2)
  270. 160    continue
  271.        CALL REPSUB(IF6)
  272.        CALL REPSUB(IF5)
  273.        CALL REPSUB(IF4)
  274.        CALL REPSUB(IF3)
  275.        CALL REPSUB(IF1)
  276.          nptmax=nptini
  277.          nfcmax=nfcini
  278.        goto 9000
  279.  9000  CONTINUE
  280.        END
  281.  
  282.  
  283.  
  284.  

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