Télécharger la plaquette Cast3M


fr en

Télécharger com444.eso

Retour à la liste

Numérotation des lignes : 

com444

  1. C COM444    SOURCE    JC220346  16/11/29    21:15:06     9221           
  2. C---------------------------------------------------------------------|
  3. C                                                                     |
  4.        SUBROUTINE COM444(II,MF1,MF2,MF3,IGAGNE)
  5. C                                                                     |
  6. C      CETTE SUBROUTINE TENTE DE CREER 3 PYRAMIDES                    |
  7. C      A PARTIR DES QUADRANGLES IF1, IF2 ET IF3 EN CREANT UN POINT    |
  8. C      CENTRAL SUPPLEMENTAIRE                                         |
  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.  
  18. -INC PPARAM
  19. -INC CCOPTIO
  20.        LOGICAL REPONS,FACET,SOLPYR,SOLTET,IN2,diago
  21.       nfcini=nfcmax
  22.       nptini=nptmax
  23.       nvini=nvol
  24.       ICTP=0
  25. C
  26. C  METTRE LES FACES DANS L'ORDRE
  27.       IF1=MF1
  28.       IP=ISUCC(IF1,II)
  29.       IF (IP.EQ.IPRED(MF2,II)) IF2=MF2
  30.       IF (IP.EQ.IPRED(MF3,II)) IF2=MF3
  31.       IP=ISUCC(IF2,II)
  32.       IF (IP.EQ.IPRED(MF2,II)) IF3=MF2
  33.       IF (IP.EQ.IPRED(MF3,II)) IF3=MF3
  34. *      WRITE(6,1000)IF1,IF2,IF3
  35. 1000   FORMAT(' COM444 IF1=',I5,'  IF2=',I5,'  IF3=',I5)
  36. C
  37.        ICTF=0
  38.        ICTV=0
  39. C
  40. C
  41. C      CREATION DU POINT CENTRAL : IP
  42. C      ------------------------------
  43.        IP1=II
  44.        IP2=ISUCC(IF1,IP1)
  45.        IP3=ISUCC(IF1,IP2)
  46.        IP4=ISUCC(IF1,IP3)
  47.        ICTP=1
  48.        NPTMAX=NPTMAX+1
  49.        IP=NPTMAX
  50. C
  51.        DO 100 I=1,4
  52. *             XYZ(I,IP)=(XYZ(I,IP1)+XYZ(I,IP2)+XYZ(I,IP3)
  53. *    #                  +XYZ(I,IP4))/4.
  54.               XYZ(I,IP)=(XYZ(I,IP2)+XYZ(I,IP4))/2.
  55. 100    CONTINUE
  56.        JP1=II
  57.        JP2=ISUCC(IF2,JP1)
  58.        JP3=ISUCC(IF2,JP2)
  59.        JP4=ISUCC(IF2,JP3)
  60. C
  61.        DO 102 I=1,4
  62. *             XYZ(I,IP)=XYZ(I,IP)+
  63. *    #   (XYZ(I,JP1)+XYZ(I,JP2)+XYZ(I,JP3)+XYZ(I,JP4))/4.
  64.               XYZ(I,IP)=XYZ(I,IP)+
  65.      #   (XYZ(I,JP2)+XYZ(I,JP4))/2.
  66. 102    CONTINUE
  67.        KP1=II
  68.        KP2=ISUCC(IF3,KP1)
  69.        KP3=ISUCC(IF3,KP2)
  70.        KP4=ISUCC(IF3,KP3)
  71. C
  72.        DO 104 I=1,4
  73. *             XYZ(I,IP)=(XYZ(I,IP)+
  74. *    #  (XYZ(I,KP1)+XYZ(I,KP2)+XYZ(I,KP3)+XYZ(I,KP4))/4.)/3.
  75.               XYZ(I,IP)=(XYZ(I,IP)+
  76.      #  (XYZ(I,KP2)+XYZ(I,KP4))/2.)/3.
  77. 104    CONTINUE
  78.        DO 103 I=1,3
  79.         XYZ(I,IP)=XYZ(I,II)+expcom*(XYZ(I,IP)-XYZ(I,II))
  80. 103    CONTINUE
  81. C
  82. *      WRITE(6,1010)IP,(XYZ(I,IP),I=1,4)
  83. 1010   FORMAT(' POINT:',I3,':',4F7.2)
  84. C
  85. *   verif des volumes
  86.        if ((vol(ip,ii,ip2,ip4).gt.0).or.
  87.      >     (vol(ip,ii,jp2,jp4).gt.0).or.
  88.      >     (vol(ip,ii,kp2,kp4).gt.0)) then
  89.          IF (IVERB.EQ.1) write (6,*) ' com444 volume positif '
  90.          nptmax=nptini
  91.          return
  92.        endif
  93.        CALL DIST(IP,JP,GL,IOK,IP1,IP2,IP3,IP4,JP2,JP3,JP4,KP2,KP3,KP4)
  94.        IF (IOK.EQ.0) THEN
  95.        NPTMAX=nptini
  96.        RETURN
  97.        ICTP=0
  98.        NPTMAX=NPTMAX-1
  99.        IP=JP
  100.        IF (IVERB.EQ.1) WRITE (6,*) ' COM444 POINT ASSIMILE  ',JP
  101.        ENDIF
  102.        REPONS=IN2(ii,IP,nfcini)
  103.        IF (REPONS) GOTO 110
  104. *      write (6,*) ' repons faux'
  105.        NPTMAX=nptini
  106.        RETURN
  107. C
  108. 110    CONTINUE
  109. C
  110. C      CREATION D'UNE PYRAMIDE : IF1+IP
  111. C      --------------------------------
  112.        IP1=ISUCC(IF1,II)
  113.        IP2=ISUCC(IF1,IP1)
  114.        IP3=ISUCC(IF1,IP2)
  115. *     recherche existence de la face
  116.        jf1=IFACE3(ip,ii,ip1)
  117. *       IF (jf1.ne.0) write (6,*) ' tetra facette assimilee'
  118.        IF (jf1.eq.0) THEN
  119.         nfcmax=nfcmax+1
  120.         jf1=nfcmax
  121.         NFC(1,jf1)=ip
  122.         NFC(2,jf1)=ii
  123.         NFC(3,jf1)=ip1
  124.         NFC(4,jf1)=0
  125.        elseif (NFC(4,jf1).ne.0.or.ipred(jf1,ip).ne.ii) then
  126.         jf1=0
  127.        endif
  128. *       write (6,*) ' com444 jf1 passe ',jf1
  129. C
  130. *     recherche existence de la face
  131.        jf2=IFACE3(ip,ip1,ip2)
  132. *       IF (jf2.ne.0) write (6,*) ' com444 facette assimilee'
  133.        IF (jf2.eq.0) THEN
  134.         nfcmax=nfcmax+1
  135.         jf2=nfcmax
  136.         NFC(1,jf2)=ip
  137.         NFC(2,jf2)=ip1
  138.         NFC(3,jf2)=ip2
  139.         NFC(4,jf2)=0
  140.        elseif (NFC(4,jf2).ne.0.or.ipred(jf2,ip).ne.ip1) then
  141.         jf2=0
  142.        endif
  143. *       write (6,*) ' com444 jf2 passe ',jf2
  144. C
  145. *     recherche existence de la face
  146.        jf3=IFACE3(ip,ip2,ip3)
  147. *       IF (jf3.ne.0) write (6,*) ' com444 facette assimilee'
  148.        IF (jf3.eq.0) THEN
  149.         nfcmax=nfcmax+1
  150.         jf3=nfcmax
  151.         NFC(1,jf3)=ip
  152.         NFC(2,jf3)=ip2
  153.         NFC(3,jf3)=ip3
  154.         NFC(4,jf3)=0
  155.        elseif (NFC(4,jf3).ne.0.or.ipred(jf3,ip).ne.ip2) then
  156.         jf3=0
  157.        endif
  158. *       write (6,*) ' com444 jf3 passe ',jf3
  159. C
  160. *     recherche existence de la face
  161.        jf4=IFACE3(ip,ip3,ii)
  162. *       IF (jf4.ne.0) write (6,*) ' com444 facette assimilee'
  163.        IF (jf4.eq.0) THEN
  164.         nfcmax=nfcmax+1
  165.         jf4=nfcmax
  166.         NFC(1,jf4)=ip
  167.         NFC(2,jf4)=ip3
  168.         NFC(3,jf4)=ii
  169.         NFC(4,jf4)=0
  170.        elseif (NFC(4,jf4).ne.0.or.ipred(jf4,ip).ne.ip3) then
  171.         jf4=0
  172.        endif
  173. *       write (6,*) ' com444 jf4 passe ',jf4
  174. C
  175.        if (diago(ip,ii,diacrd)) then
  176.         jf4=0
  177.         jf1=0
  178.        endif
  179.        if (diago(ip,ip1,diacrd)) then
  180.         jf1=0
  181.         jf2=0
  182.        endif
  183.        if (diago(ip,ip2,diacrd)) then
  184.         jf2=0
  185.         jf3=0
  186.        endif
  187.        if (diago(ip,ip3,diacrd)) then
  188.         jf3=0
  189.         jf4=0
  190.        endif
  191.        if (jf1*jf2*jf3*jf4.eq.0) then
  192. *         write (6,*) 'com444 impossibilite '
  193.         nfcmax=nfcini
  194.         jf1=0
  195.         jf2=0
  196.         jf3=0
  197.         jf4=0
  198.         goto 131
  199.        endif
  200.        CALL REPSUB(IF1)
  201.        CALL REPSUB(JF1)
  202.        CALL REPSUB(JF2)
  203.        CALL REPSUB(JF3)
  204.        CALL REPSUB(JF4)
  205. C
  206. C      LE VOLUME CREE EST-IL VALIDE ?
  207. C      ------------------------------
  208.        IF (.not.SOLPYR(IF1,JF1,JF2,JF3,JF4)) GOTO 129
  209.        IF (.NOT.FACET(JF1)) GOTO 129
  210.        IF (.NOT.FACET(JF2)) GOTO 129
  211.        IF (.NOT.FACET(JF3)) GOTO 129
  212.        IF (.NOT.FACET(JF4)) GOTO 129
  213.        goto 130
  214. C
  215. C      LE VOLUME EST INVALIDE
  216. C      ----------------------
  217.  129   continue
  218. *      write (6,*) ' solpyr 1 invalide'
  219.        NFCMAX=NFCini
  220.        CALL REPSUB(JF4)
  221.        CALL REPSUB(JF3)
  222.        CALL REPSUB(JF2)
  223.        CALL REPSUB(JF1)
  224.        CALL REPSUB(IF1)
  225.         jf1=0
  226.         jf2=0
  227.         jf3=0
  228.         jf4=0
  229.        goto 131
  230. C
  231. 130    CONTINUE
  232. C
  233. C      MEMORISATION DU VOLUME OBTENU : IF1, JF1, JF2, JF3 ET JF4
  234. C      ---------------------------------------------------------
  235.        ICTV=ICTV+1
  236.        NVOL=NVOL+1
  237.        IF (NFV(1,IF1).EQ.0) NFV(1,IF1)=NVOL
  238.        IF (NFV(1,IF1).NE.NVOL) NFV(2,IF1)=NVOL
  239.        IF (NFV(1,JF1).EQ.0) NFV(1,JF1)=NVOL
  240.        IF (NFV(1,JF1).NE.NVOL) NFV(2,JF1)=NVOL
  241.        IF (NFV(1,JF2).EQ.0) NFV(1,JF2)=NVOL
  242.        IF (NFV(1,JF2).NE.NVOL) NFV(2,JF2)=NVOL
  243.        IF (NFV(1,JF3).EQ.0) NFV(1,JF3)=NVOL
  244.        IF (NFV(1,JF3).NE.NVOL) NFV(1,JF3)=NVOL
  245.        IF (NFV(1,JF4).EQ.0) NFV(1,JF4)=NVOL
  246.        IF (NFV(1,JF4).NE.NVOL) NFV(2,JF4)=NVOL
  247.        IVOL(9,NVOL)=35
  248. C
  249.        DO 140 I=1,4
  250.               IVOL(I,NVOL)=NFC(I,IF1)
  251. 140    CONTINUE
  252.        IVOL(5,NVOL)=IP
  253. *C
  254. *       WRITE(6,1100)NVOL,(IVOL(I,NVOL),I=1,9)
  255. *1100   FORMAT(I4,4X,14I4)
  256.        if (iimpi.eq.1) write (6,1100) nfacet,(ivol(i,nvol),i=1,5)
  257. 1100   FORMAT(' COM444-1 facettes ',i5,' PYR5 ',8i5)
  258. *C
  259. *       DO 150 J=1,NPTMAX
  260. *              WRITE(6,1110)J,(NPF(I,J),I=1,40)
  261. *1110          FORMAT(I4,4X,40I3)
  262. *150    CONTINUE
  263. C  PV INC
  264. C
  265.  131    continue
  266.         nfcini=nfcmax
  267. C      2EME VOLUME : IF2+IP
  268. C      --------------------
  269.        IP1=ISUCC(IF2,II)
  270.        IP2=ISUCC(IF2,IP1)
  271.        IP3=ISUCC(IF2,IP2)
  272. C
  273. *     recherche existence de la face
  274.        kf1=IFACE3(ip,ii,ip1)
  275. *       IF (kf1.ne.0) write (6,*) ' com444 facette assimilee'
  276.        IF (kf1.eq.0) THEN
  277.         nfcmax=nfcmax+1
  278.         kf1=nfcmax
  279.         NFC(1,kf1)=ip
  280.         NFC(2,kf1)=ii
  281.         NFC(3,kf1)=ip1
  282.         NFC(4,kf1)=0
  283.        elseif (NFC(4,kf1).ne.0.or.ipred(kf1,ip).ne.ii) then
  284.         kf1=0
  285.        endif
  286. *       write (6,*) ' com444 kf1 passe ',kf1
  287. C
  288. *     recherche existence de la face
  289.        kf2=IFACE3(ip,ip1,ip2)
  290. *       IF (kf2.ne.0) write (6,*) ' com444 facette assimilee'
  291.        IF (kf2.eq.0) THEN
  292.         nfcmax=nfcmax+1
  293.         kf2=nfcmax
  294.         NFC(1,kf2)=ip
  295.         NFC(2,kf2)=ip1
  296.         NFC(3,kf2)=ip2
  297.         NFC(4,kf2)=0
  298.        elseif (NFC(4,kf2).ne.0.or.ipred(kf2,ip).ne.ip1) then
  299.         kf2=0
  300.        endif
  301. *       write (6,*) ' com444 kf2 passe ',kf2
  302. C
  303. *     recherche existence de la face
  304.        kf3=IFACE3(ip,ip2,ip3)
  305. *       IF (kf3.ne.0) write (6,*) ' com444 facette assimilee'
  306.        IF (kf3.eq.0) THEN
  307.         nfcmax=nfcmax+1
  308.         kf3=nfcmax
  309.         NFC(1,kf3)=ip
  310.         NFC(2,kf3)=ip2
  311.         NFC(3,kf3)=ip3
  312.         NFC(4,kf3)=0
  313.        elseif (NFC(4,kf3).ne.0.or.ipred(kf3,ip).ne.ip2) then
  314.         kf3=0
  315.        endif
  316. *       write (6,*) ' com444 kf3 passe ',kf3
  317. C
  318. C     ON RETOMBE SUR JF1 (si on ne l'a pas detruit)
  319.        kf4=IFACE3(ip,ip3,ii)
  320.        if (jf1.ne.0) KF4=JF1
  321. *       IF (kf4.ne.0) write (6,*) ' com444 facette deja existante'
  322.        IF (kf4.eq.0) THEN
  323.         nfcmax=nfcmax+1
  324.         kf4=nfcmax
  325.         NFC(1,kf4)=ip
  326.         NFC(2,kf4)=ip3
  327.         NFC(3,kf4)=ii
  328.         NFC(4,kf4)=0
  329.        elseif (NFC(4,kf4).ne.0.or.ipred(kf4,ip).ne.ip3) then
  330.         kf4=0
  331.        endif
  332. *       write (6,*) ' com444 kf4 passe ',kf4
  333. C
  334. C
  335.        if (diago(ip,ii,diacrd)) then
  336.         kf4=0
  337.         kf1=0
  338.        endif
  339.        if (diago(ip,ip1,diacrd)) then
  340.         kf1=0
  341.         kf2=0
  342.        endif
  343.        if (diago(ip,ip2,diacrd)) then
  344.         kf2=0
  345.         kf3=0
  346.        endif
  347.        if (diago(ip,ip3,0.999d0)) then
  348.         kf3=0
  349.         kf4=0
  350.        endif
  351.        if (kf1*kf2*kf3*kf4.eq.0) then
  352. *        write (6,*) 'com444 impossibilite '
  353.         nfcmax=nfcini
  354.         kf1=0
  355.         kf2=0
  356.         kf3=0
  357.         kf4=0
  358.         goto 161
  359.        endif
  360.        CALL REPSUB(IF2)
  361.        CALL REPSUB(KF1)
  362.        CALL REPSUB(KF2)
  363.        CALL REPSUB(KF3)
  364.        CALL REPSUB(KF4)
  365. C
  366. C      LE VOLUME CREE EST-IL VALIDE ?
  367. C      ------------------------------
  368.        if (.not.SOLPYR(IF2,KF1,KF2,KF3,KF4)) goto 160
  369.        IF (.NOT.FACET(kF1)) GOTO 160
  370.        IF (.NOT.FACET(kF2)) GOTO 160
  371.        IF (.NOT.FACET(kF3)) GOTO 160
  372.        IF (.NOT.FACET(kF4)) GOTO 160
  373.        goto 170
  374. C
  375. 160    CONTINUE
  376. C
  377. *      write (6,*) ' solpyr 2 invalide'
  378.        NFCMAX=NFCini
  379.        CALL REPSUB(KF4)
  380.        CALL REPSUB(KF3)
  381.        CALL REPSUB(KF2)
  382.        CALL REPSUB(KF1)
  383.        CALL REPSUB(IF2)
  384.         kf1=0
  385.         kf2=0
  386.         kf3=0
  387.         kf4=0
  388.        goto 161
  389. C
  390. 170    CONTINUE
  391. C
  392. C      MEMORISATION DU VOLUME IF2, LF1, KF2, KF3 ET LF4
  393. C      ------------------------------------------------
  394.        ICTV=ICTV+1
  395.        NVOL=NVOL+1
  396.        IF (NFV(1,IF2).EQ.0) NFV(1,IF2)=NVOL
  397.        IF (NFV(1,IF2).NE.NVOL) NFV(2,IF2)=NVOL
  398.        IF (NFV(1,KF1).EQ.0) NFV(1,KF1)=NVOL
  399.        IF (NFV(1,KF1).NE.NVOL) NFV(2,KF1)=NVOL
  400.        IF (NFV(1,KF2).EQ.0) NFV(1,KF2)=NVOL
  401.        IF (NFV(1,KF2).NE.NVOL) NFV(2,KF2)=NVOL
  402.        IF (NFV(1,KF3).EQ.0) NFV(1,KF3)=NVOL
  403.        IF (NFV(1,KF3).NE.NVOL) NFV(1,KF3)=NVOL
  404.        IF (NFV(1,KF4).EQ.0) NFV(1,KF4)=NVOL
  405.        IF (NFV(1,KF4).NE.NVOL) NFV(2,KF4)=NVOL
  406.        IVOL(9,NVOL)=35
  407. C
  408.        DO 180 I=1,4
  409.               IVOL(I,NVOL)=NFC(I,IF2)
  410. 180    CONTINUE
  411.        IVOL(5,NVOL)=IP
  412. *       WRITE(6,1180)NVOL,(IVOL(I,NVOL),I=1,9)
  413. *1180   FORMAT(I4,4X,14I4)
  414.        if (iimpi.eq.1) write (6,1180) nfacet,(ivol(i,nvol),i=1,5)
  415. 1180   FORMAT(' COM444-2 facettes ',i5,' PYR5 ',8i5)
  416. *C
  417. *       DO 190 J=1,NPTMAX
  418. *              WRITE(6,1190)J,(NPF(I,J),I=1,40)
  419. *1190          FORMAT(I4,4X,40I3)
  420. *190    CONTINUE
  421. C
  422.  161    continue
  423.         nfcini=nfcmax
  424. C
  425. C      3EME VOLUME : IF3+IP
  426. C      --------------------
  427.       IP1=ISUCC(IF3,II)
  428.       IP2=ISUCC(IF3,IP1)
  429.       IP3=ISUCC(IF3,IP2)
  430. C
  431. C  ON RETOMBE SUR JF4  (si on ne l'a pas detruit)
  432. C
  433.        lf1=IFACE3(ip,ii,ip1)
  434.        if (jf4.ne.0) lf1=jf4
  435. *       IF (lf1.ne.0) write (6,*) ' com444 facette deja existante'
  436.        IF (lf1.eq.0) THEN
  437.         nfcmax=nfcmax+1
  438.         lf1=nfcmax
  439.         NFC(1,lf1)=ip
  440.         NFC(2,lf1)=ii
  441.         NFC(3,lf1)=ip1
  442.         NFC(4,lf1)=0
  443.        elseif (NFC(4,lf1).ne.0.or.ipred(lf1,ip).ne.ii) then
  444.         lf1=0
  445.        endif
  446. *       write (6,*) ' com444 kf4 passe ',lf1
  447. C
  448. C
  449. *     recherche existence de la face
  450.        lf2=IFACE3(ip,ip1,ip2)
  451. *       IF (lf2.ne.0) write (6,*) ' com444 facette assimilee'
  452.        IF (lf2.eq.0) THEN
  453.         nfcmax=nfcmax+1
  454.         lf2=nfcmax
  455.         NFC(1,lf2)=ip
  456.         NFC(2,lf2)=ip1
  457.         NFC(3,lf2)=ip2
  458.         NFC(4,lf2)=0
  459.        elseif (NFC(4,lf2).ne.0.or.ipred(lf2,ip).ne.ip1) then
  460.         lf2=0
  461.        endif
  462. *       write (6,*) ' com444 lf2 passe ',lf2
  463. C
  464. *     recherche existence de la face
  465.        lf3=IFACE3(ip,ip2,ip3)
  466. *       IF (lf3.ne.0) write (6,*) ' com444 facette assimilee'
  467.        IF (lf3.eq.0) THEN
  468.         nfcmax=nfcmax+1
  469.         lf3=nfcmax
  470.         NFC(1,lf3)=ip
  471.         NFC(2,lf3)=ip2
  472.         NFC(3,lf3)=ip3
  473.         NFC(4,lf3)=0
  474.        elseif (NFC(4,lf3).ne.0.or.ipred(lf3,ip).ne.ip2) then
  475.         lf3=0
  476.        endif
  477. *       write (6,*) ' com444 lf3 passe ',lf3
  478. C
  479. C   ON RETOMBE SUR KF1  (si on ne l'a pas detruit)
  480. C
  481.        lf4=IFACE3(ip,ip3,ii)
  482.        if (kf1.ne.0) lf4=kf1
  483. *       IF (lf4.ne.0) write (6,*) ' com444 facette deja existante'
  484.        IF (lf4.eq.0) THEN
  485.         nfcmax=nfcmax+1
  486.         lf4=nfcmax
  487.         NFC(1,lf4)=ip
  488.         NFC(2,lf4)=ip3
  489.         NFC(3,lf4)=ii
  490.         NFC(4,lf4)=0
  491.        elseif (NFC(4,lf4).ne.0.or.ipred(lf4,ip).ne.ip3) then
  492.         lf4=0
  493.        endif
  494.        if (NFC(4,lf4).ne.0) lf4=0
  495. *       write (6,*) ' com444 lf4 passe ',lf4
  496. C
  497.        if (diago(ip,ii,diacrd)) then
  498.         lf4=0
  499.         lf1=0
  500.        endif
  501.        if (diago(ip,ip1,diacrd)) then
  502.         lf1=0
  503.         lf2=0
  504.        endif
  505.        if (diago(ip,ip2,diacrd)) then
  506.         lf2=0
  507.         lf3=0
  508.        endif
  509.        if (diago(ip,ip3,diacrd)) then
  510.         lf3=0
  511.         lf4=0
  512.        endif
  513.        if (lf1*lf2*lf3*lf4.eq.0) then
  514. *        write (6,*) 'com444 impossibilite '
  515.         NFCMAX=NFCini
  516.         goto 201
  517.        endif
  518. C
  519. C
  520.        CALL REPSUB(IF3)
  521.        CALL REPSUB(LF1)
  522.        CALL REPSUB(LF2)
  523.        CALL REPSUB(LF3)
  524.        CALL REPSUB(LF4)
  525. C
  526. C      LE VOLUME CREE EST-IL VALIDE ?
  527. C      ------------------------------
  528.        IF (.NOT.SOLPYR(IF3,LF1,LF2,LF3,LF4)) GOTO 200                                  IF (.NOT.FACET(LF2)) GOTO 200
  529.        IF (.NOT.FACET(LF1)) GOTO 200
  530.        IF (.NOT.FACET(LF2)) GOTO 200
  531.        IF (.NOT.FACET(LF3)) GOTO 200
  532.        IF (.NOT.FACET(LF4)) GOTO 200
  533.        GOTO 210
  534. C
  535. 200    CONTINUE
  536.        IF (IVERB.EQ.1) write (6,*) ' solpyr 3 invalide'
  537. C
  538.        NFCMAX=NFCini
  539.        CALL REPSUB(LF4)
  540.        CALL REPSUB(LF3)
  541.        CALL REPSUB(LF2)
  542.        CALL REPSUB(LF1)
  543.        CALL REPSUB(IF3)
  544.        goto 201
  545. C
  546. 210    CONTINUE
  547. C
  548. C      MEMORISATION DU VOLUME IF3, JF2, KF1, LF1 ET LF2
  549. C      ------------------------------------------------
  550.        ICTV=ICTV+1
  551.        NVOL=NVOL+1
  552.        IF (NFV(1,IF3).EQ.0) NFV(1,IF3)=NVOL
  553.        IF (NFV(1,IF3).NE.NVOL) NFV(2,IF3)=NVOL
  554.        IF (NFV(1,LF1).EQ.0) NFV(1,LF1)=NVOL
  555.        IF (NFV(1,LF1).NE.NVOL) NFV(2,LF1)=NVOL
  556.        IF (NFV(1,LF2).EQ.0) NFV(1,LF2)=NVOL
  557.        IF (NFV(1,LF2).NE.NVOL) NFV(2,LF2)=NVOL
  558.        IF (NFV(1,LF3).EQ.0) NFV(1,LF3)=NVOL
  559.        IF (NFV(1,LF3).NE.NVOL) NFV(2,LF3)=NVOL
  560.        IF (NFV(1,LF4).EQ.0) NFV(1,LF4)=NVOL
  561.        IF (NFV(1,LF4).NE.NVOL) NFV(2,LF4)=NVOL
  562.        IVOL(9,NVOL)=35
  563. C
  564.        DO 220 I=1,4
  565.               IVOL(I,NVOL)=NFC(I,IF3)
  566. 220    CONTINUE
  567.        IVOL(5,NVOL)=IP
  568. *      WRITE(6,1240)NVOL,(IVOL(I,NVOL),I=1,9)
  569. *1240   FORMAT(I4,4X,14I4)
  570.        if (iimpi.eq.1) write (6,1240) nfacet,(ivol(i,nvol),i=1,5)
  571. 1240   FORMAT(' COM444-3 facettes ',i5,' PYR5 ',8i5)
  572. C
  573. *      DO 230 J=1,NPTMAX
  574. *             WRITE(6,1250)J,(NPF(I,J),I=1,40)
  575. *1250          FORMAT(I4,4X,40I3)
  576. *230    CONTINUE
  577. C
  578.  201    continue
  579.         if (nvol.eq.nvini) then
  580.           nptmax=nptini
  581.           return
  582.         endif
  583. C
  584. 290    CONTINUE
  585. C
  586. *       if (iimpi.ne.0) write (6,*) ' comm444 point ',nptmax
  587.        IGAGNE=1
  588. *      CALL CONS33(IPRED(JF3,IP),IP,JF3,LF2,IGAG,1)
  589. *      CALL CONS33(IPRED(KF3,IP),IP,KF3,JF2,IGAG,1)
  590. *      CALL CONS33(IPRED(LF3,IP),IP,LF3,KF2,IGAG,1)
  591.        RETURN
  592. C
  593. C      FIN DE LA SUBROUTINE C4443
  594.        END
  595.  
  596.  
  597.  
  598.  

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