Télécharger la plaquette Cast3M


fr en

Télécharger hexa.eso

Retour à la liste

Numérotation des lignes : 

hexa

  1. C HEXA      SOURCE    JC220346  16/11/29    21:15:16     9221           
  2. C---------------------------------------------------------------------|
  3. C                                                                     |
  4.        SUBROUTINE HEXA(II,JJ,IF1,IF2,IGAGNE)
  5. C                                                                     |
  6. C      CETTE SUBROUTINE TENTE DE CREER UN HEXAEDRE 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. -INC PPARAM
  17. -INC CCOPTIO
  18.        LOGICAL REPONS,FACET,SOLHEX,DIAGO,IN2,PLAN,dist2
  19.        nfcini=nfcmax
  20.        nptini=nptmax
  21.        NPTSAU=NPTMAX
  22. C
  23. *      WRITE(6,1000)
  24. 1000   FORMAT(' ----->>> HEXA <<<-----')
  25. C
  26. *
  27. *  (1)  VERIFICATION DE l'ANGLE du diedre
  28. *
  29.        ANG=TETA(IF1,if2,ii,jj)
  30.        if (ang.lt.-1.d0) return
  31.        if (ang.gt.1.d0) goto 1500
  32.        IGAGNE=0
  33.        L1=0
  34.        L2=0
  35.        N3=0
  36.        N4=0
  37.        N5=0
  38.        N6=0
  39.        IF5=0
  40.        IF6=0
  41.        ICTF=0
  42.        ICTV=0
  43.        J1=IPRED(IF1,II)
  44.        J2=ISUCC(IF1,JJ)
  45.        K1=ISUCC(IF2,II)
  46.        K2=IPRED(IF2,JJ)
  47. C
  48. C      RECHERCHE DE LA FACETTE IF3
  49. C      ---------------------------
  50. C
  51.        IF3=IFACE3(K1,II,J1)
  52. *      IF (IF3.NE.0) WRITE(6,1010)IF3
  53. 1010      FORMAT(' ** IF3=',I3)
  54. C
  55.        IF (IF3.NE.0) THEN
  56.         N3=1
  57.         IF(NFC(4,IF3).EQ.0) goto 1500
  58. C  LA FACETTE DOIT ETRE QUADRANGULAIRE
  59. *     write (6,*) ' if3 trouvee',nfc(1,if3),nfc(2,if3),
  60. *   #  nfc(3,if3),nfc(4,if3)
  61.        ANG=TETA(IF1,if3,j1,ii)
  62.        if (ang.lt.-1.d0) then
  63. *       write (6,*) ' hexa probleme 1'
  64.         goto 1500
  65.        endif
  66.        ANG=TETA(IF2,if3,ii,k1)
  67.        if (ang.lt.-1.d0) then
  68. *       write (6,*) ' hexa probleme 2'
  69.         goto 1500
  70.        endif
  71.        ENDIF
  72.       IF(N3.NE.0)  L1=ISUCC(IF3,J1)
  73. C
  74. C      RECHERCHE DE LA FACETTE IF4
  75. C      ---------------------------
  76. C
  77.        IF4=IFACE3(J2,JJ,K2)
  78. *      IF (IF4.NE.0) WRITE(6,1020)IF4
  79. 1020      FORMAT(' ** IF4=',I3)
  80. C
  81.        IF (IF4.NE.0) THEN
  82.         N4=1
  83.         IF(NFC(4,IF4).EQ.0)  goto 1500
  84. C  LA FACETTE DOIT ETRE QUADRANGULAIRE
  85. *     write (6,*) ' if4 trouvee',nfc(1,if4),nfc(2,if4),
  86. *   #  nfc(3,if4),nfc(4,if4)
  87.        ANG=TETA(IF1,if4,jj,j2)
  88.        if (ang.lt.-1.d0) then
  89. *       write (6,*) ' hexa probleme 3'
  90.         goto 1500
  91.        endif
  92.        ANG=TETA(IF2,if4,k2,jj)
  93.        if (ang.lt.-1.d0) then
  94. *       write (6,*) ' hexa probleme 4'
  95.         goto 1500
  96.        endif
  97.        ENDIF
  98.       IF(N4.NE.0) L2=IPRED(IF4,J2)
  99. C
  100. C
  101. C      RECHERCHE DE LA FACETTE IF5
  102. C      ---------------------------
  103. C
  104.        IF(L1*L2.NE.0) THEN
  105.                         IF5=IFACE4(L1,L2,K1,K2)
  106.                         if (if5.lt.0) then
  107. *                        write (6,*) ' if5 trouve 3pts '
  108.                          return
  109.                         endif
  110.        ELSEIF(L1.NE.0) THEN
  111.                         IF5=IFACE3(L1,K1,K2)
  112.        ELSEIF(L2.NE.0) THEN
  113.                         IF5=IFACE3(L2,K1,K2)
  114.        ELSE
  115.         ANG=TETA(IF2,NOISIN(K1,K2,IF2),K1,K2)
  116.         IF (ANG.GT.-1.d0) IF5=NOISIN(K1,K2,IF2)
  117.        endif
  118. *      IF (IF5.NE.0) WRITE(6,1030)IF5
  119. 1030      FORMAT(' ** IF5=',I3)
  120. C
  121.        IF (IF5.NE.0) THEN
  122.         N5=1
  123.         IF(NFC(4,IF5).EQ.0)  RETURN
  124. C  LA FACETTE DOIT ETRE QUADRANGULAIRE
  125. *     write (6,*) ' if5 trouvee',if5,nfc(1,if5),nfc(2,if5),
  126. *    #  nfc(3,if5),nfc(4,if5)
  127.        ENDIF
  128.       IF (IF5.NE.0) L1=ISUCC(IF5,K1)
  129.       IF (IF5.NE.0) L2=IPRED(IF5,K2)
  130. C
  131. C
  132. C
  133. C      RECHERCHE DE LA FACETTE IF6
  134. C      ---------------------------
  135. C
  136.        IF(L1*l2.NE.0) THEN
  137.                         IF6=IFACE4(L1,L2,J1,J2)
  138.                         if (if6.lt.0) then
  139. *                        write (6,*) ' if6 trouve 3pts '
  140.                          goto 1500
  141.                         endif
  142.        ELSEIF(L1.NE.0) THEN
  143.                         IF6=IFACE3(L1,J1,J2)
  144.        ELSEIF(L2.NE.0) THEN
  145.                         IF6=IFACE3(L2,J1,J2)
  146.        ELSE
  147.         ANG=TETA(IF1,NOISIN(J2,J1,IF1),J2,J1)
  148.         IF (ANG.GT.-1.d0) IF6=NOISIN(J2,J1,if1)
  149.        endif
  150. *      IF (IF6.NE.0) WRITE(6,1040)IF6
  151. 1040      FORMAT(' ** IF5=',I3)
  152. C
  153.        IF (IF6.NE.0) THEN
  154.         N6=1
  155.         IF(NFC(4,IF6).EQ.0)  goto 1500
  156. C  LA FACETTE DOIT ETRE QUADRANGULAIRE
  157. *     write (6,*) ' if6 trouvee',if6,nfc(1,if6),nfc(2,if6),
  158. *    #  nfc(3,if6),nfc(4,if6)
  159.        ENDIF
  160.       IF (IF6.NE.0) L1=IPRED(IF6,J1)
  161.       IF (IF6.NE.0) L2=ISUCC(IF6,J2)
  162. C
  163. *
  164. *  (1)  VERIFICATION DES ANGLES AVEC FACETTES ADJACENTES (MINI 90)
  165. *
  166.       IF (N6.EQ.0) THEN
  167.        ANG=TETA(IF1,NOISIN(J2,J1,IF1),J2,J1)
  168. *       write (6,*) 'facette 1 angle 1',ang
  169.        IF (ANG.GT.-1.d0) goto 1500
  170.       ENDIF
  171.       IF (N3.EQ.0) THEN
  172.        ANG=TETA(IF1,NOISIN(J1,II,IF1),J1,II)
  173. *       write (6,*) 'facette 1 angle 2',ang
  174.        IF (ANG.GT.-1.d0) goto 1500
  175.       ENDIF
  176.       IF (N4.EQ.0) THEN
  177.        ANG=TETA(IF1,NOISIN(JJ,J2,IF1),JJ,J2)
  178. *       write (6,*) 'facette 1 angle 3',ang
  179.        IF (ANG.GT.-1.d0) goto 1500
  180.       ENDIF
  181.       IF (N5.EQ.0) THEN
  182.        ANG=TETA(IF2,NOISIN(K1,K2,IF2),K1,K2)
  183. *       write (6,*) 'facette 2 angle 1',ang
  184.        IF (ANG.GT.-1.d0) goto 1500
  185.       ENDIF
  186.       IF (N4.EQ.0) THEN
  187.        ANG=TETA(IF2,NOISIN(K2,JJ,IF2),K2,JJ)
  188. *       write (6,*) 'facette 2 angle 2',ang
  189.        IF (ANG.GT.-1.d0) goto 1500
  190.       ENDIF
  191.       IF (N3.EQ.0) THEN
  192.        ANG=TETA(IF2,NOISIN(II,K1,IF2),II,K1)
  193. *       write (6,*) 'facette 2 angle 3',ang
  194.        IF (ANG.GT.-1.d0) goto 1500
  195.       ENDIF
  196. *  a ameliorer plus tard
  197. C
  198. C
  199. C   Construction des deux points supplementaires (si necessaire)
  200. C
  201.       IF(L1.EQ.0) THEN
  202.           L1=NPTMAX+1
  203.           NPTMAX=L1
  204. C
  205. C      DETERMINATION DES COORDONNEES DU NOUVEAU POINT L1
  206. C      -------------------------------------------------
  207.              xj1=xyz(1,j1)-xyz(1,ii)
  208.              yj1=xyz(2,j1)-xyz(2,ii)
  209.              zj1=xyz(3,j1)-xyz(3,ii)
  210.              vj1=xj1**2+yj1**2+zj1**2
  211.              xk1=xyz(1,k1)-xyz(1,ii)
  212.              yk1=xyz(2,k1)-xyz(2,ii)
  213.              zk1=xyz(3,k1)-xyz(3,ii)
  214.              vk1=xk1**2+yk1**2+zk1**2
  215.              scal=xj1*xk1+yj1*yk1+zj1*zk1
  216.           xyz(1,l1)=(xyz(1,k1)+xj1-scal*xk1/vk1+
  217.      *               xyz(1,j1)+xk1-scal*xj1/vj1)*0.5d0
  218.           xyz(2,l1)=(xyz(2,k1)+yj1-scal*yk1/vk1+
  219.      *               xyz(2,j1)+yk1-scal*yj1/vj1)*0.5d0
  220.           xyz(3,l1)=(xyz(3,k1)+zj1-scal*zk1/vk1+
  221.      *               xyz(3,j1)+zk1-scal*zj1/vj1)*0.5d0
  222.           DO 150 I=1,3
  223. ******       XYZ(I,L1)=(XYZ(I,L1)+XYZ(I,J1)+XYZ(I,K1)-XYZ(I,II))*0.5d0
  224.              XYZ(I,L1)=           XYZ(I,J1)+XYZ(I,K1)-XYZ(I,II)
  225. 150       CONTINUE
  226.          if (L2.ne.0) then
  227.       do 151 i=1,3
  228.         XYZ(I,L1)=(XYZ(I,L1)+XYZ(I,J1)+XYZ(I,L2)-XYZ(I,J2)+
  229.      *  XYZ(I,K1)+XYZ(I,L2)-XYZ(I,K2))/3.d0
  230. 151   continue
  231.          endif
  232.           XYZ(4,L1)=(XYZ(4,J1)+XYZ(4,K1)+XYZ(4,II))/3.d0
  233.             CALL DIST(L1,KP,GL,IOK,II,JJ,J1,J2,K1,K2,L2,0,0,0)
  234.         IF (IOK.EQ.0) THEN
  235. *  C'est rate
  236.           nptmax=nptsau
  237.           goto 1500
  238. C          l1=kp
  239. C           write (6,*) 'hexa point assimile 1 ',kp
  240. C           if (diago(l1,j1,0.95D0)) then
  241. C*            write (6,*) ' diago quad',l1,j1
  242. C             NPTMAX=NPTsau
  243. C           goto 1500
  244. C           endif
  245. C           if (diago(l1,k1,0.95D0)) then
  246. C*            write (6,*) ' diago quad',l1,k1
  247. C             NPTMAX=NPTsau
  248. C             goto 1500
  249. C           endif
  250.         ENDIF
  251. *        if (dist2(l1)) then
  252. *         nptmax=nptsau
  253. *         return
  254. *        endif
  255.          XYZ(1,L1+1)=XYZ(1,JJ)+1.35*(XYZ(1,L1)-XYZ(1,JJ))
  256.          XYZ(2,L1+1)=XYZ(2,JJ)+1.35*(XYZ(2,L1)-XYZ(2,JJ))
  257.          XYZ(3,L1+1)=XYZ(3,JJ)+1.35*(XYZ(3,L1)-XYZ(3,JJ))
  258.          XYZ(4,L1+1)=XYZ(4,JJ)+1.35*(XYZ(4,L1)-XYZ(4,JJ))
  259. *       IF (.NOT.IN2(jj,L1+1,nfcini)) THEN
  260. *         write (6,*) ' in incorrect 1'
  261. *         nptmax=nptsau
  262. *         goto 1500
  263. *       ENDIF
  264. *        if (dist2(l1+1)) then
  265. *         nptmax=nptsau
  266. *         return
  267. *        endif
  268.          CALL DIST(L1+1,KP,GL,IOK,II,JJ,J1,J2,K1,K2,L1,L2,0,0)
  269.          IF (IOK.EQ.0) THEN
  270. *  C'est encore rate
  271.            NPTMAX=NPTSAU
  272.             IF (IVERB.EQ.1) write (6,*) 'point mal place 1.1',kp
  273.            goto 1500
  274.          ENDIF
  275.       ENDIF
  276. *  verif que l1 appartient bien a n3 n5 et n6 si ils existent
  277.       if (n3.ne.0) then
  278.        if (L1.ne.ISUCC(IF3,J1)) then
  279. *       write (6,*) ' faces ne correspondent pas '
  280.         nptmax=nptsau
  281.         goto 1500
  282.        endif
  283.       endif
  284.       if (n5.ne.0) then
  285.        if (L1.ne.ISUCC(IF5,K1)) then
  286. *       write (6,*) ' faces ne correspondent pas '
  287.         nptmax=nptsau
  288.         goto 1500
  289.        endif
  290.       endif
  291.       if (n6.ne.0) then
  292.        if (L1.ne.IPRED(IF6,J1)) then
  293. *       write (6,*) ' faces ne correspondent pas '
  294.         nptmax=nptsau
  295.         goto 1500
  296.        endif
  297.       endif
  298.       IF(L2.EQ.0) THEN
  299.           L2=NPTMAX+1
  300.           NPTMAX=L2
  301. C
  302. C      DETERMINATION DES COORDONNEES DU NOUVEAU POINT L2
  303. C      -------------------------------------------------
  304.              xj2=xyz(1,j2)-xyz(1,jj)
  305.              yj2=xyz(2,j2)-xyz(2,jj)
  306.              zj2=xyz(3,j2)-xyz(3,jj)
  307.              vj2=xj2**2+yj2**2+zj2**2
  308.              xk2=xyz(1,k2)-xyz(1,jj)
  309.              yk2=xyz(2,k2)-xyz(2,jj)
  310.              zk2=xyz(3,k2)-xyz(3,jj)
  311.              vk2=xk2**2+yk2**2+zk2**2
  312.              scal=xj2*xk2+yj2*yk2+zj2*zk2
  313.           xyz(1,l2)=(xyz(1,k2)+xj2-scal*xk2/vk2+
  314.      *               xyz(1,j2)+xk2-scal*xj2/vj2)*0.5d0
  315.           xyz(2,l2)=(xyz(2,k2)+yj2-scal*yk2/vk2+
  316.      *               xyz(2,j2)+yk2-scal*yj2/vj2)*0.5d0
  317.           xyz(3,l2)=(xyz(3,k2)+zj2-scal*zk2/vk2+
  318.      *               xyz(3,j2)+zk2-scal*zj2/vj2)*0.5d0
  319.           DO 170 I=1,3
  320. **********   XYZ(I,L2)=(XYZ(I,L2)+XYZ(I,J2)+XYZ(I,K2)-XYZ(I,JJ))*0.5d0
  321.              XYZ(I,L2)=           XYZ(I,J2)+XYZ(I,K2)-XYZ(I,JJ)
  322. 170       CONTINUE
  323.          if (L1.ne.0) then
  324.       do 171 i=1,3
  325.         XYZ(I,L2)=(XYZ(I,L2)+XYZ(I,J2)+XYZ(I,L1)-XYZ(I,J1)+
  326.      *  XYZ(I,L1)+XYZ(I,K2)-XYZ(I,K1))/3.d0
  327. 171   continue
  328.          endif
  329.           XYZ(4,L2)=(XYZ(4,J2)+XYZ(4,K2)+XYZ(4,JJ))/3.d0
  330.             CALL DIST(L2,KP,GL,IOK,II,JJ,J1,J2,K1,K2,L1,0,0,0)
  331.         IF (IOK.EQ.0) THEN
  332. *  C'est rate
  333.           nptmax=nptsau
  334.           goto 1500
  335. C          l2=kp
  336. C           write (6,*) 'hexa point assimile 2 ',kp
  337. C           if (diago(l2,j2,0.95d0)) then
  338. C*            write (6,*) ' diago quad',l1,j1
  339. C            NPTMAX=NPTsau
  340. C            goto 1500
  341. C           endif
  342. C           if (diago(l2,k2,0.95d0)) then
  343. C*            write (6,*) ' diago quad',l2,k2
  344. C            NPTMAX=NPTsau
  345. C            goto 1500
  346. C           endif
  347. C           if (diago(l2,l1,0.95d0)) then
  348. C*            write (6,*) ' diago quad',l2,l1
  349. C            NPTMAX=NPTsau
  350. C            goto 1500
  351. C           endif
  352.         ENDIF
  353. *        if (dist2(l2)) then
  354. *         nptmax=nptsau
  355. *         return
  356. *        endif
  357.          XYZ(1,L2+1)=XYZ(1,II)+1.35*(XYZ(1,L2)-XYZ(1,II))
  358.          XYZ(2,L2+1)=XYZ(2,II)+1.35*(XYZ(2,L2)-XYZ(2,II))
  359.          XYZ(3,L2+1)=XYZ(3,II)+1.35*(XYZ(3,L2)-XYZ(3,II))
  360.          XYZ(4,L2+1)=XYZ(4,II)+1.35*(XYZ(4,L2)-XYZ(4,II))
  361. *       IF (.NOT.IN2(ii,L2+1,nfcini)) THEN
  362. *         write (6,*) ' in incorrect 2'
  363. *         nptmax=nptsau
  364. *         goto 1500
  365. *       ENDIF
  366. *        if (dist2(l2+1)) then
  367. *         nptmax=nptsau
  368. *         return
  369. *        endif
  370.              CALL DIST(L2+1,KP,GL,IOK,II,JJ,J1,J2,K1,K2,L1,L2,0,0)
  371.          IF (IOK.EQ.0) THEN
  372. **  C'est encore rate
  373.            NPTMAX=NPTSAU
  374.             IF (IVERB.EQ.1) write (6,*) 'point mal place 2.2',kp
  375.            goto 1500
  376.          ENDIF
  377.       ENDIF
  378. *  verif que l2 appartient bien a n4 n5 et n6 si ils existent
  379.       if (n4.ne.0) then
  380.        if (L2.ne.IPRED(IF4,J2)) then
  381. *       write (6,*) ' faces ne correspondent pas '
  382.         nptmax=nptsau
  383.         goto 1500
  384.        endif
  385.       endif
  386.       if (n5.ne.0) then
  387.        if (L2.ne.IPRED(IF5,K2)) then
  388. *       write (6,*) ' faces ne correspondent pas '
  389.         nptmax=nptsau
  390.         goto 1500
  391.        endif
  392.       endif
  393.       if (n6.ne.0) then
  394.        if (L2.ne.ISUCC(IF6,J2)) then
  395. *       write (6,*) ' faces ne correspondent pas '
  396.         nptmax=nptsau
  397.         goto 1500
  398.        endif
  399.       endif
  400.         IF (DIAGO(L1,L2,0.95D0)) THEN
  401. *        write (6,*) ' diago quad',L1,L2
  402.          NPTMAX=NPTsau
  403.          goto 1500
  404.         ENDIF
  405. C
  406. C
  407. C
  408. C      CONSTRUCTION DU CUBE
  409. C      --------------------
  410. C
  411.        IF (IF3.EQ.0) THEN
  412. C
  413. C      CREATION DE LA FACETTE IF3
  414. C      --------------------------
  415.        IF3=IFACE4(IPRED(IF1,II),II,ISUCC(IF2,II),L1)
  416.        if (if3.lt.0) then
  417. *                       write (6,*) ' if3 trouve 3pts '
  418.                         nfcmax=nfcini
  419.                         nptmax=nptini
  420.                         return
  421.        elseif (if3.eq.0) then
  422.        NFCMAX=NFCMAX+1
  423.        IF3=NFCMAX
  424.        ICTF=ICTF+1
  425. C
  426.        NFC(1,IF3)=IPRED(IF1,II)
  427.        NFC(2,IF3)=II
  428.        NFC(3,IF3)=ISUCC(IF2,II)
  429.        NFC(4,IF3)=L1
  430. C
  431.        ENDIF
  432.        ENDIF
  433. C
  434. C
  435.        IF (IF4.EQ.0) THEN
  436. C
  437. C      CREATION DE LA FACETTE IF4
  438. C      --------------------------
  439.        IF4=IFACE4(JJ,ISUCC(IF1,JJ),L2,IPRED(IF2,JJ))
  440.        if (if4.lt.0) then
  441. *                       write (6,*) ' if4 trouve 3pts '
  442.                         nfcmax=nfcini
  443.                         nptmax=nptini
  444.                         return
  445.        elseif (if4.eq.0) then
  446.        NFCMAX=NFCMAX+1
  447.        IF4=NFCMAX
  448.        ICTF=ICTF+1
  449. C
  450.        NFC(1,IF4)=JJ
  451.        NFC(2,IF4)=ISUCC(IF1,JJ)
  452.        NFC(3,IF4)=L2
  453.        NFC(4,IF4)=IPRED(IF2,JJ)
  454. C
  455.        ENDIF
  456.        ENDIF
  457. C
  458. C
  459.        IF (IF5.EQ.0)  THEN
  460. C
  461. C      CREATION DE LA FACETTE IF5
  462. C      --------------------------
  463.        IF5=IFACE4(l1,k1,k2,l2)
  464.        if (if5.lt.0) then
  465. *                       write (6,*) ' if5 trouve 3pts '
  466.                         nfcmax=nfcini
  467.                         nptmax=nptini
  468.                         return
  469.        elseif (if5.eq.0) then
  470.        NFCMAX=NFCMAX+1
  471.        IF5=NFCMAX
  472.        ICTF=ICTF+1
  473. C
  474.        NFC(1,IF5)=L1
  475.        NFC(2,IF5)=K1
  476.        NFC(3,IF5)=K2
  477.        NFC(4,IF5)=L2
  478. C
  479. C
  480.        ENDIF
  481.        ENDIF
  482.        IF (IF6.EQ.0)  THEN
  483. C
  484. C      CREATION DE LA FACETTE IF6
  485. C      --------------------------
  486.        IF6=IFACE4(j1,l1,l2,j2)
  487.        if (if6.lt.0) then
  488. *                       write (6,*) ' if6 trouve 3pts '
  489.                         nfcmax=nfcini
  490.                         nptmax=nptini
  491.                         return
  492.        elseif (if6.eq.0) then
  493.        NFCMAX=NFCMAX+1
  494.        IF6=NFCMAX
  495.        ICTF=ICTF+1
  496. C
  497.        NFC(1,IF6)=J1
  498.        NFC(2,IF6)=L1
  499.        NFC(3,IF6)=L2
  500.        NFC(4,IF6)=J2
  501. C
  502. C
  503.        ENDIF
  504.        ENDIF
  505. C
  506. C      ON ENLEVE LES FACETTES IF1, IF2 ET IF3
  507. C      --------------------------------------
  508.        CALL REPSUB(IF1)
  509.        CALL REPSUB(IF2)
  510.        CALL REPSUB(IF3)
  511.        CALL REPSUB(IF4)
  512.        CALL REPSUB(IF5)
  513.        CALL REPSUB(IF6)
  514. C
  515. C      LE VOLUME CREE EST-IL VALIDE ?
  516. C      ------------------------------
  517.        IF (.NOT.PLAN(IF3)) GOTO 160
  518. *      write (6,*) ' plan(if3) passe'
  519.        IF (.NOT.PLAN(IF4)) GOTO 160
  520. *      write (6,*) ' plan(if4) passe'
  521.        IF (.NOT.PLAN(IF5)) GOTO 160
  522. *      write (6,*) ' plan(if5) passe'
  523.        IF (.NOT.PLAN(IF6)) GOTO 160
  524. *      write (6,*) ' plan(if6) passe'
  525.        IF (.NOT.FACET(IF3)) GOTO 160
  526. *      write (6,*) ' facet(if3) passe'
  527.        IF (.NOT.FACET(IF4)) GOTO 160
  528. *      write (6,*) ' facet(if4) passe'
  529.        IF (.NOT.FACET(IF5)) GOTO 160
  530. *      write (6,*) ' facet(if5) passe'
  531.        IF (.NOT.FACET(IF6)) GOTO 160
  532. *      write (6,*) ' facet(if6) passe'
  533.        IF (.NOT.SOLHEX(IF1,IF2,IF3,IF4,IF5,IF6)) GOTO 160
  534. *      write (6,*) ' solhex passe'
  535. *
  536. *  VERIFICATION TAILLE
  537.         IF (N3.EQ.0.AND.N5.EQ.0) THEN
  538.          KF1=IPRED(IF1,II)
  539.          KF2=ISUCC(IF2,II)
  540.           DNORM=(XYZ(1,KF1)-XYZ(1,KF2))**2
  541.      #         +(XYZ(2,KF1)-XYZ(2,KF2))**2
  542.      #         +(XYZ(3,KF1)-XYZ(3,KF2))**2
  543.           DTEST=tcrit*XYZ(4,KF1)*XYZ(4,KF2)
  544.           IF (DNORM.GT.DTEST) GOTO 160
  545.         ENDIF
  546.         IF (N4.EQ.0.AND.N5.EQ.0) THEN
  547.          KF1=IPRED(IF2,JJ)
  548.          KF2=ISUCC(IF1,JJ)
  549.           DNORM=(XYZ(1,KF1)-XYZ(1,KF2))**2
  550.      #         +(XYZ(2,KF1)-XYZ(2,KF2))**2
  551.      #         +(XYZ(3,KF1)-XYZ(3,KF2))**2
  552.           DTEST=tcrit*XYZ(4,KF1)*XYZ(4,KF2)
  553.           IF (DNORM.GT.DTEST) GOTO 160
  554.         ENDIF
  555. *     write (6,*) 'hexa a cree un cube numero nfacet ',nvol+1,nfacet
  556. C
  557. C      LE VOLUME CREE EST VALIDE |
  558. C      ---------------------------
  559. C      MEMORISATION DU VOLUME IF1, IF2, IF3, IF4 ET IF5
  560. C      ------------------------------------------------
  561.        NVOL=NVOL+1
  562.        IF (NFV(1,IF1).EQ.0) NFV(1,IF1)=NVOL
  563.        IF (NFV(1,IF1).NE.NVOL) NFV(2,IF1)=NVOL
  564.        IF (NFV(1,IF2).EQ.0) NFV(1,IF2)=NVOL
  565.        IF (NFV(1,IF2).NE.NVOL) NFV(2,IF2)=NVOL
  566.        IF (NFV(1,IF3).EQ.0) NFV(1,IF3)=NVOL
  567.        IF (NFV(1,IF3).NE.NVOL) NFV(2,IF3)=NVOL
  568.        IF (NFV(1,IF4).EQ.0) NFV(1,IF4)=NVOL
  569.        IF (NFV(1,IF4).NE.NVOL) NFV(2,IF4)=NVOL
  570.        IF (NFV(1,IF5).EQ.0) NFV(1,IF5)=NVOL
  571.        IF (NFV(1,IF5).NE.NVOL) NFV(2,IF5)=NVOL
  572.        IF (NFV(1,IF6).EQ.0) NFV(1,IF6)=NVOL
  573.        IF (NFV(1,IF6).NE.NVOL) NFV(2,IF6)=NVOL
  574.        IVOL(9,NVOL)=20
  575.        IVOL(1,NVOL)=II
  576.        IVOL(2,NVOL)=JJ
  577.        IVOL(3,NVOL)=J2
  578.        IVOL(4,NVOL)=J1
  579.        IVOL(5,NVOL)=K1
  580.        IVOL(6,NVOL)=K2
  581.        IVOL(7,NVOL)=L2
  582.        IVOL(8,NVOL)=L1
  583. C
  584. *      WRITE(6,1100)NVOL,(IVOL(I,NVOL),I=1,9)
  585.        if (iimpi.eq.1) write (6,1100) nfacet,(ivol(i,nvol),i=1,8)
  586. 1100   FORMAT(' HEXA facettes ',i5,' cub8 ',8i5)
  587. C
  588. *      DO 150 J=1,NPTMAX
  589. *              WRITE(6,1110)J,(NPF(I,J),I=1,40)
  590. *1110          FORMAT(I4,4X,40I3)
  591. *150    CONTINUE
  592. C
  593.        IGAGNE=1
  594. C
  595.        RETURN
  596. C
  597. 160    CONTINUE
  598. *       write (6,*) ' probleme en validant le cube '
  599. C
  600. C      LE VOLUME CREE N'EST PAS VALIDE: IL FAUT DONC DETRUIRE LES FACETT
  601. C      CREEES. ---------------------------------------------------------
  602.        CALL REPSUB(IF1)
  603.        CALL REPSUB(IF2)
  604.        CALL REPSUB(IF3)
  605.        CALL REPSUB(IF4)
  606.        CALL REPSUB(IF5)
  607.        CALL REPSUB(IF6)
  608. C
  609.        NFCMAX=NFCMAX-ICTF
  610. C
  611.        NPTMAX=NPTSAU
  612.  1500 continue
  613. *  maintenant on essaye un prisme
  614.        NPTMAX=NPTSAU
  615. *      call prism1(II,JJ,IF1,IF2,IGAGNE)
  616.        return
  617.        end
  618.  
  619.  
  620.  
  621.  
  622.  
  623.  
  624.  

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