Numérotation des lignes :

com443
C COM443    SOURCE    JC220346  16/11/29    21:15:05     9221           C---------------------------------------------------------------------|C                                                                     |       SUBROUTINE COM443(II,MF1,MF2,MF3,IGAGNE)C                                                                     |C      CETTE SUBROUTINE TENTE DE CREER 2 PYRAMIDES ET 1 TETRAEDRE     |C      A PARTIR DES QUADRANGLES IF1, IF2 ET DU TRIANGLE IF3 EN        |C      CREANT UN POINT                                                |C      CENTRAL SUPPLEMENTAIRE                                         |C      - IGAGNE=1 EN CAS DE SUCCES                                    |C      - IGAGNE=0 EN CAS D'ECHEC                                      |C                                                                     |C---------------------------------------------------------------------|C      IMPLICIT INTEGER(I-N)      IMPLICIT REAL*8(A-H,O-Z)-INC TDEMAIT -INC PPARAM-INC CCOPTIO       LOGICAL REPONS,FACET,SOLPYR,SOLTET,IN2,diago      nfcini=nfcmax      nptini=nptmax      nvini=nvol      ICTP=0      ipin = 0CC  METTRE LES FACES DANS L'ORDRE      IF3=MF3      IP=ISUCC(IF3,II)      IF (IP.EQ.IPRED(MF1,II)) IF1=MF1      IF (IP.EQ.IPRED(MF2,II)) IF1=MF2      IP=ISUCC(IF1,II)      IF (IP.EQ.IPRED(MF1,II)) IF2=MF1      IF (IP.EQ.IPRED(MF2,II)) IF2=MF2*      WRITE(6,1000)IF1,IF2,IF31000   FORMAT(' COM443 IF1=',I5,'  IF2=',I5,'  IF3=',I5)C       ICTF=0       ICTV=0CCC      CREATION DU POINT CENTRAL : IPC      ------------------------------       IP1=II       IP2=ISUCC(IF1,IP1)       IP3=ISUCC(IF1,IP2)       IP4=ISUCC(IF1,IP3)       ICTP=1       NPTMAX=NPTMAX+1       IP=NPTMAXC       DO 100 I=1,4*             XYZ(I,IP)=(XYZ(I,IP1)+XYZ(I,IP2)+XYZ(I,IP3)*    #                  +XYZ(I,IP4))/4.              XYZ(I,IP)=(XYZ(I,IP2)+XYZ(I,IP4))/2.100    CONTINUE       JP1=II       JP2=ISUCC(IF2,JP1)       JP3=ISUCC(IF2,JP2)       JP4=ISUCC(IF2,JP3)C       DO 102 I=1,4*             XYZ(I,IP)=XYZ(I,IP)+*    #   (XYZ(I,JP1)+XYZ(I,JP2)+XYZ(I,JP3)+XYZ(I,JP4))/4.              XYZ(I,IP)=XYZ(I,IP)+     #   (XYZ(I,JP2)+XYZ(I,JP4))/2.102    CONTINUE       KP1=II       KP2=ISUCC(IF3,KP1)       KP3=ISUCC(IF3,KP2)C       DO 104 I=1,4              XYZ(I,IP)=(XYZ(I,IP)+     #  (XYZ(I,KP2)+XYZ(I,KP3))/2.)/3.104    CONTINUE       DO 103 I=1,3         XYZ(I,IP)=XYZ(I,II)+expcom*(XYZ(I,IP)-XYZ(I,II))103    CONTINUEC*      WRITE(6,1010)IP,(XYZ(I,IP),I=1,4)1010   FORMAT(' POINT:',I3,':',4F7.2)*   verif des volumes       if ((vol(ip,ii,ip2,ip4).gt.0).or.     >     (vol(ip,ii,jp2,jp4).gt.0).or.     >     (vol(ip,ii,kp2,kp3).gt.0)) then         IF (IVERB.EQ.1) write (6,*) ' com443 volume positif '         nptmax=nptini         return       endifC       CALL DIST(IP,JP,GL,IOK,IP1,IP2,IP3,IP4,JP2,JP3,JP4,KP2,KP3,0)       IF (IOK.EQ.0) THEN       NPTMAX=NPTini       RETURN       ICTP=0       NPTMAX=NPTMAX-1       IP=JP*      WRITE (6,*) ' COM443 POINT ASSIMILE ',JP       ENDIF       REPONS=IN2(ii,IP,nfcini)       IF (REPONS) GOTO 110       NPTMAX=NPTini       RETURNC110    CONTINUECC      CREATION D'UNE PYRAMIDE : IF1+IPC      --------------------------------       IP1=ISUCC(IF1,II)       IP2=ISUCC(IF1,IP1)       IP3=ISUCC(IF1,IP2)*     recherche existence de la face       jf1=IFACE3(ip,ii,ip1)*       IF (jf1.ne.0) write (6,*) ' com443 facette assimilee'       IF (jf1.eq.0) THEN        nfcmax=nfcmax+1        jf1=nfcmax        NFC(1,jf1)=ip        NFC(2,jf1)=ii        NFC(3,jf1)=ip1        NFC(4,jf1)=0       elseif (NFC(4,jf1).ne.0.or.ipred(jf1,ip).ne.ii) then        jf1=0       endif*       write (6,*) ' com443 jf1 passe ',jf1C*     recherche existence de la face       jf2=IFACE3(ip,ip1,ip2)*       IF (jf2.ne.0) write (6,*) ' com443 facette assimilee'       IF (jf2.eq.0) THEN        nfcmax=nfcmax+1        jf2=nfcmax        NFC(1,jf2)=ip        NFC(2,jf2)=ip1        NFC(3,jf2)=ip2        NFC(4,jf2)=0       elseif (NFC(4,jf2).ne.0.or.ipred(jf2,ip).ne.ip1) then        jf2=0       endif*       write (6,*) ' com443 jf2 passe ',jf2C*     recherche existence de la face       jf3=IFACE3(ip,ip2,ip3)*       IF (jf3.ne.0) write (6,*) ' com443 facette assimilee'       IF (jf3.eq.0) THEN        nfcmax=nfcmax+1        jf3=nfcmax        NFC(1,jf3)=ip        NFC(2,jf3)=ip2        NFC(3,jf3)=ip3        NFC(4,jf3)=0       elseif (NFC(4,jf3).ne.0.or.ipred(jf3,ip).ne.ip2) then        jf3=0       endif*       write (6,*) ' com443 jf3 passe ',jf3C*     recherche existence de la face       jf4=IFACE3(ip,ip3,ii)*       IF (jf4.ne.0) write (6,*) ' com443 facette assimilee'       IF (jf4.eq.0) THEN        nfcmax=nfcmax+1        jf4=nfcmax        NFC(1,jf4)=ip        NFC(2,jf4)=ip3        NFC(3,jf4)=ii        NFC(4,jf4)=0       elseif (NFC(4,jf4).ne.0.or.ipred(jf4,ip).ne.ip3) then        jf4=0       endif*       write (6,*) ' com443 jf4 passe ',jf4C       if (diago(ip,ii,diacrd)) then        jf4=0        jf1=0       endif       if (diago(ip,ip1,diacrd)) then        jf1=0        jf2=0       endif       if (diago(ip,ip2,diacrd)) then        jf2=0        jf3=0       endif       if (diago(ip,ip3,diacrd)) then        jf3=0        jf4=0       endif       if (jf1*jf2*jf3*jf4.eq.0) then*        write (6,*) 'com443 impossibilite '        nfcmax=nfcini        jf1=0        jf2=0        jf3=0        jf4=0        goto 131       endif       CALL REPSUB(IF1)       CALL REPSUB(JF1)       CALL REPSUB(JF2)       CALL REPSUB(JF3)       CALL REPSUB(JF4)CC      LE VOLUME CREE EST-IL VALIDE ?C      ------------------------------       IF (.not.SOLPYR(IF1,JF1,JF2,JF3,JF4)) GOTO 129       IF (.NOT.FACET(jF1)) GOTO 129       IF (.NOT.FACET(jF2)) GOTO 129       IF (.NOT.FACET(jF3)) GOTO 129       IF (.NOT.FACET(jF4)) GOTO 129       goto 130CC      LE VOLUME EST INVALIDEC      ---------------------- 129   continue*      write (6,*) ' solpyr 1 invalide'       NFCMAX=NFCini       CALL REPSUB(JF4)       CALL REPSUB(JF3)       CALL REPSUB(JF2)       CALL REPSUB(JF1)       CALL REPSUB(IF1)        jf1=0        jf2=0        jf3=0        jf4=0       goto 131C130    CONTINUECC      MEMORISATION DU VOLUME OBTENU : IF1, JF1, JF2, JF3 ET JF4C      ---------------------------------------------------------       ICTV=ICTV+1       NVOL=NVOL+1       IF (NFV(1,IF1).EQ.0) NFV(1,IF1)=NVOL       IF (NFV(1,IF1).NE.NVOL) NFV(2,IF1)=NVOL       IF (NFV(1,JF1).EQ.0) NFV(1,JF1)=NVOL       IF (NFV(1,JF1).NE.NVOL) NFV(2,JF1)=NVOL       IF (NFV(1,JF2).EQ.0) NFV(1,JF2)=NVOL       IF (NFV(1,JF2).NE.NVOL) NFV(2,JF2)=NVOL       IF (NFV(1,JF3).EQ.0) NFV(1,JF3)=NVOL       IF (NFV(1,JF3).NE.NVOL) NFV(2,JF3)=NVOL       IF (NFV(1,JF4).EQ.0) NFV(1,JF4)=NVOL       IF (NFV(1,JF4).NE.NVOL) NFV(2,JF4)=NVOL       IVOL(9,NVOL)=35C       DO 140 I=1,4              IVOL(I,NVOL)=NFC(I,IF1)140    CONTINUE       IVOL(5,NVOL)=IP*C*       WRITE(6,1100)NVOL,(IVOL(I,NVOL),I=1,9)*1100   FORMAT(I4,4X,14I4)       if (iimpi.eq.1) write (6,1100) nfacet,(ivol(i,nvol),i=1,5)1100   FORMAT(' COM443-1 facettes ',i5,' PYR5 ',8i5)*C*       DO 150 J=1,NPTMAX*              WRITE(6,1110)J,(NPF(I,J),I=1,40)*1110          FORMAT(I4,4X,40I3)*150    CONTINUEC  PV INCC 131    continue        nfcini=nfcmaxC      2EME VOLUME : IF2+IPC      --------------------       IP1=ISUCC(IF2,II)       IP2=ISUCC(IF2,IP1)       IP3=ISUCC(IF2,IP2)C*     recherche existence de la face       kf1=IFACE3(ip,ii,ip1)*       IF (kf1.ne.0) write (6,*) ' com443 facette assimilee'       IF (kf1.eq.0) THEN        nfcmax=nfcmax+1        kf1=nfcmax        NFC(1,kf1)=ip        NFC(2,kf1)=ii        NFC(3,kf1)=ip1        NFC(4,kf1)=0       elseif (NFC(4,kf1).ne.0.or.ipred(kf1,ip).ne.ii) then        kf1=0       endif*       write (6,*) ' com443 kf1 passe ',kf1C*     recherche existence de la face       kf2=IFACE3(ip,ip1,ip2)*       IF (kf2.ne.0) write (6,*) ' com443 facette assimilee'       IF (kf2.eq.0) THEN        nfcmax=nfcmax+1        kf2=nfcmax        NFC(1,kf2)=ip        NFC(2,kf2)=ip1        NFC(3,kf2)=ip2        NFC(4,kf2)=0       elseif (NFC(4,kf2).ne.0.or.ipred(kf2,ip).ne.ip1) then        kf2=0       endif*       write (6,*) ' com443 kf2 passe ',kf2C*     recherche existence de la face       kf3=IFACE3(ip,ip2,ip3)*       IF (kf3.ne.0) write (6,*) ' com443 facette assimilee'       IF (kf3.eq.0) THEN        nfcmax=nfcmax+1        kf3=nfcmax        NFC(1,kf3)=ip        NFC(2,kf3)=ip2        NFC(3,kf3)=ip3        NFC(4,kf3)=0       elseif (NFC(4,kf3).ne.0.or.ipred(kf3,ip).ne.ip2) then        kf3=0       endif*       write (6,*) ' com443 kf3 passe ',kf3CC     ON RETOMBE SUR JF1 (si on ne l'a pas detruit)C       kf4=IFACE3(ip,ip3,ii)*       IF (kf4.ne.0) write (6,*) ' com443 facette deja existante'       IF (kf4.eq.0) THEN        nfcmax=nfcmax+1        kf4=nfcmax        NFC(1,kf4)=ip        NFC(2,kf4)=ip3        NFC(3,kf4)=ii        NFC(4,kf4)=0       elseif (NFC(4,kf4).ne.0.or.ipred(kf4,ip).ne.ip3) then        kf4=0       endif*       write (6,*) ' com443 kf4 passe ',kf4CC       if (diago(ip,ii,diacrd)) then        kf4=0        kf1=0       endif       if (diago(ip,ip1,diacrd)) then        kf1=0        kf2=0       endif       if (diago(ip,ip2,diacrd)) then        kf2=0        kf3=0       endif       if (diago(ip,ip3,diacrd)) then        kf3=0        kf4=0       endif       if (kf1*kf2*kf3*kf4.eq.0) then*        write (6,*) 'com443 impossibilite '        nfcmax=nfcini        kf1=0        kf2=0        kf3=0        kf4=0        goto 161       endif       CALL REPSUB(IF2)       CALL REPSUB(KF1)       CALL REPSUB(KF2)       CALL REPSUB(KF3)       CALL REPSUB(KF4)CC      LE VOLUME CREE EST-IL VALIDE ?C      ------------------------------       if (.not.SOLPYR(IF2,KF1,KF2,KF3,KF4)) GOTO 160       IF (.NOT.FACET(KF1)) GOTO 160       IF (.NOT.FACET(KF2)) GOTO 160       IF (.NOT.FACET(KF3)) GOTO 160       IF (.NOT.FACET(KF4)) GOTO 160       goto 170C160    CONTINUEC*      write (6,*) ' solpyr 2 invalide'       NFCMAX=NFCini       CALL REPSUB(KF4)       CALL REPSUB(KF3)       CALL REPSUB(KF2)       CALL REPSUB(KF1)       CALL REPSUB(IF2)        kf1=0        kf2=0        kf3=0        kf4=0       goto 161C170    CONTINUECC      MEMORISATION DU VOLUME IF2, LF1, KF2, KF3 ET LF4C      ------------------------------------------------       ICTV=ICTV+1       NVOL=NVOL+1       IF (NFV(1,IF2).EQ.0) NFV(1,IF2)=NVOL       IF (NFV(1,IF2).NE.NVOL) NFV(2,IF2)=NVOL       IF (NFV(1,kF1).EQ.0) NFV(1,kF1)=NVOL       IF (NFV(1,kF1).NE.NVOL) NFV(2,kF1)=NVOL       IF (NFV(1,kF2).EQ.0) NFV(1,kF2)=NVOL       IF (NFV(1,kF2).NE.NVOL) NFV(2,kF2)=NVOL       IF (NFV(1,kF3).EQ.0) NFV(1,kF3)=NVOL       IF (NFV(1,kF3).NE.NVOL) NFV(2,kF3)=NVOL       IF (NFV(1,kF4).EQ.0) NFV(1,kF4)=NVOL       IF (NFV(1,kF4).NE.NVOL) NFV(2,kF4)=NVOL       IVOL(9,NVOL)=35C       DO 180 I=1,4              IVOL(I,NVOL)=NFC(I,IF2)180    CONTINUE       IVOL(5,NVOL)=IP*       WRITE(6,1180)NVOL,(IVOL(I,NVOL),I=1,9)*1180   FORMAT(I4,4X,14I4)       if (iimpi.eq.1) write (6,1180) nfacet,(ivol(i,nvol),i=1,5)1180   FORMAT(' COM443-2 facettes ',i5,' PYR5 ',8i5)*C*       DO 190 J=1,NPTMAX*              WRITE(6,1190)J,(NPF(I,J),I=1,40)*1190          FORMAT(I4,4X,40I3)*190    CONTINUEC 161    continue        nfcini=nfcmaxCC      3EME VOLUME : IF3+IPC      --------------------      IP1=ISUCC(IF3,II)      IP2=ISUCC(IF3,IP1)C  ON RETOMBE SUR JF4  (si on ne l'a pas detruit)C       lf1=IFACE3(ip,ii,ip1)*      IF (lf1.ne.0) write (6,*) ' com443 facette deja existante'       IF (lf1.eq.0) THEN        nfcmax=nfcmax+1        lf1=nfcmax        NFC(1,lf1)=ip        NFC(2,lf1)=ii        NFC(3,lf1)=ip1        NFC(4,lf1)=0       elseif (NFC(4,lf1).ne.0.or.ipred(lf1,ip).ne.ii) then        lf1=0       endif*       write (6,*) ' com443 lf1 passe ',lf1CC*     recherche existence de la face       lf2=IFACE3(ip,ip1,ip2)*       IF (lf2.ne.0) write (6,*) ' com443 facette assimilee'       IF (lf2.eq.0) THEN        nfcmax=nfcmax+1        lf2=nfcmax        NFC(1,lf2)=ip        NFC(2,lf2)=ip1        NFC(3,lf2)=ip2        NFC(4,lf2)=0       elseif (NFC(4,lf2).ne.0.or.ipred(lf2,ip).ne.ip1) then        lf2=0       endif*       write (6,*) ' com443 lf2 passe ',lf2CC   ON RETOMBE SUR KF1  (si on ne l'a pas detruit)C       lf3=IFACE3(ip,ip2,ii)*       IF (lf3.ne.0) write (6,*) ' com443 facette deja existante'       IF (lf3.eq.0) THEN        nfcmax=nfcmax+1        lf3=nfcmax        NFC(1,lf3)=ip        NFC(2,lf3)=ip2        NFC(3,lf3)=ii        NFC(4,lf3)=0       elseif (NFC(4,lf3).ne.0.or.ipred(lf3,ip).ne.ip2) then        lf3=0       endif*       write (6,*) ' com443 lf3 passe ',lf3C       if (diago(ip,ii,diacrd)) then        lf3=0        lf1=0       endif       if (diago(ip,ip1,diacrd)) then        lf1=0        lf2=0       endif       if (diago(ip,ip2,diacrd)) then        lf2=0        lf3=0       endif       if (lf1*lf2*lf3.eq.0) then*        write (6,*) 'com443 impossibilite '        NFCMAX=NFCini        goto 201       endifCC       CALL REPSUB(IF3)       CALL REPSUB(LF1)       CALL REPSUB(LF2)       CALL REPSUB(LF3)CC      LE VOLUME CREE EST-IL VALIDE ?C      ------------------------------       IF (.NOT.SOLTET(IF3,LF1,LF2,LF3,ipin)) GOTO 200       IF (.NOT.FACET(LF1)) GOTO 200       IF (.NOT.FACET(LF2)) GOTO 200       IF (.NOT.FACET(LF3)) GOTO 200       GOTO 210C200    CONTINUE*      write (6,*) ' soltet 3 invalide'C       NFCMAX=NFCini       CALL REPSUB(LF3)       CALL REPSUB(LF2)       CALL REPSUB(LF1)       CALL REPSUB(IF3)       goto 201C210    CONTINUECC      MEMORISATION DU VOLUME IF3, JF2, KF1, LF1 ET LF2C      ------------------------------------------------       ICTV=ICTV+1       NVOL=NVOL+1       IF (NFV(1,IF3).EQ.0) NFV(1,IF3)=NVOL       IF (NFV(1,IF3).NE.NVOL) NFV(2,IF3)=NVOL       IF (NFV(1,lF1).EQ.0) NFV(1,lF1)=NVOL       IF (NFV(1,lF1).NE.NVOL) NFV(2,lF1)=NVOL       IF (NFV(1,lF2).EQ.0) NFV(1,lF2)=NVOL       IF (NFV(1,lF2).NE.NVOL) NFV(2,lF2)=NVOL       IF (NFV(1,lF3).EQ.0) NFV(1,lF3)=NVOL       IF (NFV(1,lF3).NE.NVOL) NFV(2,lF3)=NVOL       IVOL(9,NVOL)=25C       DO 220 I=1,3              IVOL(I,NVOL)=NFC(I,IF3)220    CONTINUE       IVOL(4,NVOL)=IP*      WRITE(6,1240)NVOL,(IVOL(I,NVOL),I=1,9)*1240   FORMAT(I4,4X,14I4)       if (iimpi.eq.1) write (6,1240) nfacet,(ivol(i,nvol),i=1,4)1240   FORMAT(' COM443-3 facettes ',i5,' TET4 ',8i5)C*      DO 230 J=1,NPTMAX*             WRITE(6,1250)J,(NPF(I,J),I=1,40)*1250          FORMAT(I4,4X,40I3)*230    CONTINUEC 201    continue        if (nvol.eq.nvini) then          nptmax=nptini          return        endifC290    CONTINUEC*       if (iimpi.ne.0) write (6,*) ' comm443 point ',nptmax       IGAGNE=1*      CALL CONS33(IPRED(KF3,IP),IP,KF3,JF2,IGAG,1)       RETURNCC      FIN DE LA SUBROUTINE COM443       END     

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