C DEMETE SOURCE PV 20/04/01 21:15:26 10569 C|-------------------------------------------------------------------| C| | C| INTERFACE ENTRE VOLUME ET DEMAIT | C| ALLOUE LES TABLEAUX ET LES INITIALISE | C| | C|-------------------------------------------------------------------| C SUBROUTINE DEMETE(MELEME) C IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) SEGMENT ICPR(nbpts) SEGMENT IDCP(NPTINI) -INC SMCOORD -INC PPARAM -INC CCOPTIO -INC CCGEOME -INC SMELEME -INC TDEMAIT DATA IPREM/0/ IF (IDIM.NE.3) CALL ERREUR(16) IF (IERR.NE.0) RETURN MELSUR=MELEME IPT8=MELEME SEGACT MELEME NBELEM=NUM(/2) NBSOUS=LISOUS(/1) IF (NBSOUS.EQ.0) GOTO 100 DO 10 IOB=1,NBSOUS IPT1=LISOUS(IOB) SEGACT IPT1 NBELEM=NBELEM+IPT1.NUM(/2) 10 CONTINUE 100 CONTINUE * LES DIMENSIONS SERONT AJUSTEES EN FONCTION DES BESOINS DANS DEMAIT NFTOT=NBELEM+100 SEGINI NFC SEGINI NFV SEGACT MCOORD*mod SEGINI ICPR C* DO 200 I=1,nbpts C* ICPR(I)=0 C* 200 CONTINUE IK=0 IELBAS=0 IPT1=MELEME IDEGR=0 DO 220 IOB=1,MAX(1,LISOUS(/1)) IF (LISOUS(/1).NE.0) IPT1=LISOUS(IOB) L=IPT1.NUM(/1) IF (IDEGR.EQ.0) THEN IF (IPT1.ITYPEL.EQ.4.OR.IPT1.ITYPEL.EQ.8) IDEGR=1 IF (IPT1.ITYPEL.EQ.6.OR.IPT1.ITYPEL.EQ.10) IDEGR=2 ELSEIF (IDEGR.EQ.1) THEN IF (IPT1.ITYPEL.EQ.6.OR.IPT1.ITYPEL.EQ.10) CALL ERREUR(16) ELSEIF (IDEGR.EQ.2) THEN IF (IPT1.ITYPEL.EQ.4.OR.IPT1.ITYPEL.EQ.8) CALL ERREUR(16) ENDIF IF (IDEGR.EQ.0) CALL ERREUR(16) IF (IERR.NE.0) GOTO 1000 DO 230 INB=1,L,IDEGR DO 230 IEL=1,IPT1.NUM(/2) IP=IPT1.NUM(INB,IEL) IF (ICPR(IP).NE.0) GOTO 240 IK=IK+1 ICPR(IP)=IK 240 CONTINUE NFC((INB-1)/IDEGR+1,IEL+IELBAS)=ICPR(IP) 230 CONTINUE IF (L.EQ.4.OR.L.EQ.8) GOTO 260 DO 250 IEL=1,IPT1.NUM(/2) NFC(4,IEL+IELBAS)=0 250 CONTINUE 260 CONTINUE IELBAS=IELBAS+IPT1.NUM(/2) IF (LISOUS(/1).NE.0) SEGDES IPT1 220 CONTINUE NVTOT=50 NPTOT=IK+50 SEGINI NPF,IFUT,XYZ,IVOL,IFAT SEGDES MELEME NFCMAX=IELBAS NFACET=NFCMAX NVOL=0 NPTMAX=IK NPTINI=NPTMAX SEGINI IDCP DO 500 I=1,nbpts if (icpr(i).ne.0) IDCP(ICPR(I))=I 500 CONTINUE C REMPLIR IFUT DO 400 I=1,NFACET IFUT(I)=I 400 CONTINUE DO 300 IP=1,nbpts IPL=ICPR(IP) IF (IPL.EQ.0) GOTO 300 IREF=4*(IP-1) DO 310 IC=1,3 XYZ(IC,IPL)=XCOOR(IREF+IC) 310 CONTINUE 300 CONTINUE SEGSUP ICPR IF (IPREM.EQ.0.AND.IVERB.EQ.1) WRITE (IOIMP,*) # ' DEMETE VERSION 2.0.beta (C) CEA/SEMT - P VERPEAUX ' IPREM=1 * WRITE (IOIMP,2000) NFCMAX,NFACET,NVOL,NPTMAX *2000 FORMAT (' DEMETE NFCMAX ',I5,' NFACET ',I5,' NVOL ',I5, * # ' NPTMAX ',I5) NPTBAS=nbpts IF (IVERB.EQ.1) WRITE(IOIMP,*) ' nptbas,nptini ',nptbas,nptini CALL DEMAIT(idcp,nptbas) IF (IERR.NE.0) GOTO 1100 IF (NVOL.EQ.0) GOTO 1100 IF (IVERB.EQ.1) WRITE (IOIMP,*) ' DEMETE MISSION ACCOMPLIE ' * WRITE (IOIMP,9702) NPTBAS,NPTINI,NPTMAX *9702 FORMAT(' DEMETE NPTBAS ',I5,' NPTINI ',I5,' NPTMAX ',I5) IF (NPTINI.EQ.NPTMAX) GOTO 5001 NBPTA=nbpts NBPTS=NBPTA+NPTMAX-NPTINI SEGADJ MCOORD DO 5000 I=NPTINI+1,NPTMAX DO 5010 J=1,4 XCOOR(NBPTA*4+J)=XYZ(J,I) 5010 CONTINUE NBPTA=NBPTA+1 5000 CONTINUE 5001 CONTINUE NHE=0 NPR=0 NPY=0 NTE=0 DO 5800 I=1,NVOL IF (IVOL(9,I).NE.20) GOTO 5805 NHE=NHE+1 GOTO 5800 5805 IF (IVOL(9,I).NE.30) GOTO 5810 NPR=NPR+1 GOTO 5800 5810 IF (IVOL(9,I).NE.35) GOTO 5815 NPY=NPY+1 GOTO 5800 5815 IF (IVOL(9,I).NE.25) GOTO 5800 NTE=NTE+1 5800 CONTINUE IF (IVERB.EQ.1) WRITE (IOIMP,50002) NHE,NPR,NPY,NTE 50002 FORMAT(' HEXAEDRES PRISMES PYRAMIDES TETRAEDRES ',4I6) C POUR EVITER LES ENNUIS AVEC L'OPTIMISEUR IPT1=IVOL IPT2=IVOL IPT3=IVOL IPT4=IVOL IPT5=IVOL NBS=0 NBSOUS=0 NBREF=0 IF (NHE.EQ.0) GOTO 5900 NBNN=8 NBELEM=NHE SEGINI IPT1 IPT5=IPT1 IPT1.ITYPEL=14 NBS=NBS+1 5900 IF (NPR.EQ.0) GOTO 5901 NBNN=6 NBELEM=NPR SEGINI IPT2 IPT5=IPT2 IPT2.ITYPEL=16 NBS=NBS+1 5901 IF (NPY.EQ.0) GOTO 5902 NBNN=5 NBELEM=NPY SEGINI IPT3 IPT5=IPT3 IPT3.ITYPEL=25 NBS=NBS+1 5902 IF (NTE.EQ.0) GOTO 5903 NBNN=4 NBELEM=NTE SEGINI IPT4 IPT5=IPT4 IPT4.ITYPEL=23 NBS=NBS+1 5903 CONTINUE NHE=0 NPR=0 NPY=0 NTE=0 DO 6000 I=1,NVOL IF (IVOL(9,I).NE.20) GOTO 6010 NHE=NHE+1 IPT1.ICOLOR(NHE)=IDCOUL DO 6001 J=1,8 IP=IVOL(J,I) IF (IP.LE.NPTINI) THEN IPT1.NUM(J,NHE)=IDCP(IP) ELSE IPT1.NUM(J,NHE)=IP-NPTINI+NPTBAS ENDIF 6001 CONTINUE GOTO 6000 6010 IF (IVOL(9,I).NE.30) GOTO 6020 NPR=NPR+1 IPT2.ICOLOR(NPR)=IDCOUL DO 6011 J=1,6 IP=IVOL(J,I) IF (IP.LE.NPTINI) THEN IPT2.NUM(J,NPR)=IDCP(IP) ELSE IPT2.NUM(J,NPR)=IP-NPTINI+NPTBAS ENDIF 6011 CONTINUE GOTO 6000 6020 IF (IVOL(9,I).NE.35) GOTO 6030 NPY=NPY+1 IPT3.ICOLOR(NPY)=IDCOUL DO 6021 J=1,5 IP=IVOL(J,I) IF (IP.LE.NPTINI) THEN IPT3.NUM(J,NPY)=IDCP(IP) ELSE IPT3.NUM(J,NPY)=IP-NPTINI+NPTBAS ENDIF 6021 CONTINUE GOTO 6000 6030 IF (IVOL(9,I).NE.25) GOTO 6000 NTE=NTE+1 IPT4.ICOLOR(NTE)=IDCOUL DO 6031 J=1,4 IP=IVOL(J,I) IF (IP.LE.NPTINI) THEN IPT4.NUM(J,NTE)=IDCP(IP) ELSE IPT4.NUM(J,NTE)=IP-NPTINI+NPTBAS ENDIF 6031 CONTINUE 6000 CONTINUE IF (NBS.EQ.1) GOTO 6200 NBREF=1 NBELEM=0 NBNN=0 NBSOUS=NBS SEGINI MELEME LISREF(1)=IPT8 NBS=0 IF (NHE.EQ.0) GOTO 6100 NBS=NBS+1 LISOUS(NBS)=IPT1 NBNN=IPT1.NUM(/1) NBELEM=IPT1.NUM(/2) SEGDES IPT1 6100 IF (NPR.EQ.0) GOTO 6101 NBS=NBS+1 LISOUS(NBS)=IPT2 SEGDES IPT2 6101 IF (NPY.EQ.0) GOTO 6102 NBS=NBS+1 LISOUS(NBS)=IPT3 SEGDES IPT3 6102 IF (NTE.EQ.0) GOTO 6103 NBS=NBS+1 LISOUS(NBS)=IPT4 SEGDES IPT4 6103 CONTINUE SEGDES MELEME GOTO 1100 1100 SEGSUP IDCP GOTO 1020 6200 CONTINUE NBREF=1 NBSOUS=0 NBNN=IPT5.NUM(/1) NBELEM=IPT5.NUM(/2) SEGINI MELEME LISREF(1)=IPT8 ITYPEL=IPT5.ITYPEL DO 6210 J=1,NBELEM ICOLOR(J)=IPT5.ICOLOR(J) DO 6210 I=1,NBNN NUM(I,J)=IPT5.NUM(I,J) 6210 CONTINUE SEGSUP IPT5 SEGDES MELEME GOTO 1100 1000 SEGSUP ICPR 1020 SEGSUP NFC,NFV,NPF,IFUT,XYZ,IVOL,ICPR,IFAT IF (IDEGR.EQ.2) CALL DEMCHA(MELSUR,MELEME) RETURN END