Télécharger la plaquette Cast3M


fr en

Télécharger com443.eso

Retour à la liste

Numérotation des lignes : 

com443

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

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