C COM433 SOURCE JC220346 16/11/29 21:15:04 9221 C---------------------------------------------------------------------| C | SUBROUTINE COM433(II,MF1,MF2,MF3,IGAGNE) C | C CETTE SUBROUTINE TENTE DE CREER 1 PYRAMIDE ET 2 TETRAEDRES | C A PARTIR DU QUADRANGLE IF1 ET DES TRIANGLES IF2 ET IF3 EN | C CREANT UN POINT 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 = 0 C C METTRE LES FACES DANS L'ORDRE IF1=MF1 IP=ISUCC(IF1,II) IF (IP.EQ.IPRED(MF2,II)) IF2=MF2 IF (IP.EQ.IPRED(MF3,II)) IF2=MF3 IP=ISUCC(IF2,II) IF (IP.EQ.IPRED(MF2,II)) IF3=MF2 IF (IP.EQ.IPRED(MF3,II)) IF3=MF3 * WRITE(6,1000)IF1,IF2,IF3 1000 FORMAT(' COM433 IF1=',I5,' IF2=',I5,' IF3=',I5) C ICTF=0 ICTV=0 C C C CREATION DU POINT CENTRAL : IP C ------------------------------ IP1=II IP2=ISUCC(IF1,IP1) IP3=ISUCC(IF1,IP2) IP4=ISUCC(IF1,IP3) ICTP=1 NPTMAX=NPTMAX+1 IP=NPTMAX C 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) C DO 102 I=1,4 XYZ(I,IP)=XYZ(I,IP)+ # (XYZ(I,JP2)+XYZ(I,JP3))/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 CONTINUE C * WRITE(6,1010)IP,(XYZ(I,IP),I=1,4) 1010 FORMAT(' POINT:',I3,':',4F7.2) C * verif des volumes if ((vol(ip,ii,ip2,ip4).gt.0).or. > (vol(ip,ii,jp2,jp3).gt.0).or. > (vol(ip,ii,kp2,kp3).gt.0)) then IF (IVERB.EQ.1) write (6,*) ' com433 volume positif ' nptmax=nptini return endif C CALL DIST(IP,JP,GL,IOK,IP1,IP2,IP3,IP4,JP2,JP3,KP2,KP3,0,0) IF (IOK.EQ.0) THEN NPTMAX=NPTini RETURN ICTP=0 NPTMAX=NPTMAX-1 IP=JP return * WRITE (6,*) ' COM433 POINT ASSIMILE ',JP ENDIF REPONS=IN2(ii,IP,nfcini) IF (REPONS) GOTO 110 NPTMAX=NPTini RETURN C 110 CONTINUE C C CREATION D'UNE PYRAMIDE : IF1+IP C -------------------------------- 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,*) ' com433 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,ii).ne.ip1) then jf1=0 endif * write (6,*) ' com433 jf1 passe ',jf1 C * recherche existence de la face jf2=IFACE3(ip,ip1,ip2) * IF (jf2.ne.0) write (6,*) ' com433 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 if (NFC(4,jf2).ne.0) jf2=0 * write (6,*) ' com433 jf2 passe ',jf2 C * recherche existence de la face jf3=IFACE3(ip,ip2,ip3) * IF (jf3.ne.0) write (6,*) ' com433 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,*) ' com433 jf3 passe ',jf3 C * recherche existence de la face jf4=IFACE3(ip,ip3,ii) * IF (jf4.ne.0) write (6,*) ' com433 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 if (NFC(4,jf4).ne.0) jf4=0 * write (6,*) ' com433 jf4 passe ',jf4 C if (diago(ip,ii,diacrd)) then jf4=0 jf1=0 endif if (diago(ip,ip1,diacrd)) then * write (6,*) ' com433 jf4 echec diago - 1 ',ip,ip1 jf1=0 jf2=0 endif if (diago(ip,ip2,diacrd)) then * write (6,*) ' com433 jf4 echec diago - 2 ',ip,ip2 jf2=0 jf3=0 endif if (diago(ip,ip3,diacrd)) then * write (6,*) ' com433 jf4 echec diago - 3 ',ip,ip3 jf3=0 jf4=0 endif if (jf1*jf2*jf3*jf4.eq.0) then * write (6,*) 'com433 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) C C 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 130 C C LE VOLUME EST INVALIDE C ---------------------- 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 131 C 130 CONTINUE C C MEMORISATION DU VOLUME OBTENU : IF1, JF1, JF2, JF3 ET JF4 C --------------------------------------------------------- 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)=35 C DO 140 I=1,4 IVOL(I,NVOL)=NFC(I,IF1) 140 CONTINUE IVOL(5,NVOL)=IP *C if (iimpi.eq.1) write (6,1100) nfacet,(ivol(i,nvol),i=1,5) 1100 FORMAT(' COM433-1 facettes ',i5,' PYR5 ',5i5) *C * DO 150 J=1,NPTMAX * WRITE(6,1110)J,(NPF(I,J),I=1,40) 1110 FORMAT(I4,4X,40I3) *150 CONTINUE C PV INC C 131 continue if (nvol.eq.nvini) then nptmax=nptini return endif nfcini=nfcmax C 2EME VOLUME : IF2+IP C -------------------- IP1=ISUCC(IF2,II) IP2=ISUCC(IF2,IP1) C * recherche existence de la face kf1=IFACE3(ip,ii,ip1) * IF (kf1.ne.0) write (6,*) ' com433 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,*) ' com433 kf1 passe ',kf1 C * recherche existence de la face kf2=IFACE3(ip,ip1,ip2) * IF (kf2.ne.0) write (6,*) ' com433 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,*) ' com433 kf2 passe ',kf2 C * recherche existence de la face kf3=IFACE3(ip,ip2,ii) * IF (kf3.ne.0) write (6,*) ' com433 facette assimilee' IF (kf3.eq.0) THEN nfcmax=nfcmax+1 kf3=nfcmax NFC(1,kf3)=ip NFC(2,kf3)=ip2 NFC(3,kf3)=ii NFC(4,kf3)=0 elseif (NFC(4,kf3).ne.0.or.ipred(kf3,ip).ne.ip2) then kf3=0 endif * write (6,*) ' com433 kf3 passe ',kf3 C if (diago(ip,ii,diacrd)) then kf3=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 (kf1*kf2*kf3.eq.0) then * write (6,*) 'com433 impossibilite ' nfcmax=nfcini kf1=0 kf2=0 kf3=0 goto 161 endif CALL REPSUB(IF2) CALL REPSUB(KF1) CALL REPSUB(KF2) CALL REPSUB(KF3) C C LE VOLUME CREE EST-IL VALIDE ? C ------------------------------ if (.not.SOLTET(IF2,KF1,KF2,KF3,ipin)) goto 160 IF (.NOT.FACET(kF1)) GOTO 160 IF (.NOT.FACET(kF2)) GOTO 160 IF (.NOT.FACET(kF3)) GOTO 160 GOTO 170 C 160 CONTINUE C * write (6,*) ' soltet 2 invalide' NFCMAX=NFCini CALL REPSUB(KF3) CALL REPSUB(KF2) CALL REPSUB(KF1) CALL REPSUB(IF2) kf1=0 kf2=0 kf3=0 goto 161 C 170 CONTINUE C C MEMORISATION DU VOLUME IF2, LF1, KF2, KF3 ET LF4 C ------------------------------------------------ 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 IVOL(9,NVOL)=25 C DO 180 I=1,3 IVOL(I,NVOL)=NFC(I,IF2) 180 CONTINUE IVOL(4,NVOL)=IP if (iimpi.eq.1) write (6,1180) nfacet,(ivol(i,nvol),i=1,4) 1180 FORMAT(' COM433-2 facettes ',i5,' TET4 ',4i5) *C * DO 190 J=1,NPTMAX * WRITE(6,1190)J,(NPF(I,J),I=1,40) 1190 FORMAT(I4,4X,40I3) *190 CONTINUE C 161 continue nfcini=nfcmax C C 3EME VOLUME : IF3+IP C -------------------- 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,*) ' com433 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,*) ' com433 lf1 passe ',lf1 C C * recherche existence de la face lf2=IFACE3(ip,ip1,ip2) * IF (lf2.ne.0) write (6,*) ' com433 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,*) ' com433 lf2 passe ',lf2 C C ON RETOMBE SUR KF1 (si on ne l'a pas detruit) C lf3=IFACE3(ip,ip2,ii) * IF (lf3.ne.0) write (6,*) ' com433 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,*) ' com433 lf3 passe ',lf3 C 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,*) 'com433 impossibilite ' NFCMAX=NFCini goto 201 endif C C CALL REPSUB(IF3) CALL REPSUB(LF1) CALL REPSUB(LF2) CALL REPSUB(LF3) C C 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 210 C 200 CONTINUE * write (6,*) ' soltet 3 invalide' C NFCMAX=NFCini CALL REPSUB(LF3) CALL REPSUB(LF2) CALL REPSUB(LF1) CALL REPSUB(IF3) goto 201 C 210 CONTINUE C C MEMORISATION DU VOLUME IF3, JF2, KF1, LF1 ET LF2 C ------------------------------------------------ ICTV=ICTV+1 NVOL=NVOL+1 IF (NFV(1,IF3).EQ.0) NFV(1,IF2)=NVOL IF (NFV(1,IF3).NE.NVOL) NFV(2,IF2)=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)=25 C DO 220 I=1,3 IVOL(I,NVOL)=NFC(I,IF3) 220 CONTINUE IVOL(4,NVOL)=IP if (iimpi.eq.1) write (6,1240) nfacet,(ivol(i,nvol),i=1,4) 1240 FORMAT(' COM433-3 facettes ',i5,' TET4 ',4i5) C * DO 230 J=1,NPTMAX * WRITE(6,1250)J,(NPF(I,J),I=1,40) 1250 FORMAT(I4,4X,40I3) *230 CONTINUE C 201 continue if (nvol.eq.nvini) then nptmax=nptini return endif C * if (iimpi.ne.0) write (6,*) ' comm433 point ',nptmax IGAGNE=1 RETURN C C FIN DE LA SUBROUTINE COM433 END