1 : C DEMETE SOURCE FANDEUR 11/07/19 21:15:55 7039 2 : C|-------------------------------------------------------------------| 3 : C| | 4 : C| INTERFACE ENTRE VOLUME ET DEMAIT | 5 : C| ALLOUE LES TABLEAUX ET LES INITIALISE | 6 : C| | 7 : C|-------------------------------------------------------------------| 8 : C 9 : SUBROUTINE DEMETE(MELEME) 10 : C 11 : IMPLICIT INTEGER(I-N) 12 : IMPLICIT REAL*8(A-H,O-Z) 13 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 14 : SEGMENT IDCP(NPTINI) 15 : -INC SMCOORD 16 : -INC CCOPTIO 17 : -INC CCGEOME 18 : -INC SMELEME 19 : -INC TDEMAIT 20 : DATA IPREM/0/ 20 : IF (IDIM.NE.3) CALL ERREUR(16) 21 : IF (IERR.NE.0) RETURN 22 : MELSUR=MELEME 23 : IPT8=MELEME 24 : SEGACT MELEME 25 : NBELEM=NUM(/2) 26 : NBSOUS=LISOUS(/1) 27 : IF (NBSOUS.EQ.0) GOTO 100 28 : DO 10 IOB=1,NBSOUS 29 : IPT1=LISOUS(IOB) 30 : SEGACT IPT1 31 : NBELEM=NBELEM+IPT1.NUM(/2) 32 : 10 CONTINUE 33 : 100 CONTINUE 34 : * LES DIMENSIONS SERONT AJUSTEES EN FONCTION DES BESOINS DANS DEMAIT 35 : NFTOT=NBELEM+100 36 : SEGINI NFC 37 : SEGINI NFV 38 : SEGACT MCOORD 39 : SEGINI ICPR 40 : C* DO 200 I=1,XCOOR(/1)/(IDIM+1) 41 : C* ICPR(I)=0 42 : C* 200 CONTINUE 43 : IK=0 44 : IELBAS=0 45 : IPT1=MELEME 46 : IDEGR=0 47 : DO 220 IOB=1,MAX(1,LISOUS(/1)) 48 : IF (LISOUS(/1).NE.0) IPT1=LISOUS(IOB) 49 : L=IPT1.NUM(/1) 50 : IF (IDEGR.EQ.0) THEN 51 : IF (IPT1.ITYPEL.EQ.4.OR.IPT1.ITYPEL.EQ.8) IDEGR=1 52 : IF (IPT1.ITYPEL.EQ.6.OR.IPT1.ITYPEL.EQ.10) IDEGR=2 53 : ELSEIF (IDEGR.EQ.1) THEN 53 : IF (IPT1.ITYPEL.EQ.6.OR.IPT1.ITYPEL.EQ.10) CALL ERREUR(16) 54 : ELSEIF (IDEGR.EQ.2) THEN 54 : IF (IPT1.ITYPEL.EQ.4.OR.IPT1.ITYPEL.EQ.8) CALL ERREUR(16) 55 : ENDIF 55 : IF (IDEGR.EQ.0) CALL ERREUR(16) 56 : IF (IERR.NE.0) GOTO 1000 57 : DO 230 INB=1,L,IDEGR 58 : DO 230 IEL=1,IPT1.NUM(/2) 59 : IP=IPT1.NUM(INB,IEL) 60 : IF (ICPR(IP).NE.0) GOTO 240 61 : IK=IK+1 62 : ICPR(IP)=IK 63 : 240 CONTINUE 64 : NFC((INB-1)/IDEGR+1,IEL+IELBAS)=ICPR(IP) 65 : 230 CONTINUE 66 : IF (L.EQ.4.OR.L.EQ.8) GOTO 260 67 : DO 250 IEL=1,IPT1.NUM(/2) 68 : NFC(4,IEL+IELBAS)=0 69 : 250 CONTINUE 70 : 260 CONTINUE 71 : IELBAS=IELBAS+IPT1.NUM(/2) 72 : IF (LISOUS(/1).NE.0) SEGDES IPT1 73 : 220 CONTINUE 74 : NVTOT=50 75 : NPTOT=IK+50 76 : SEGINI NPF,IFUT,XYZ,IVOL,IFAT 77 : SEGDES MELEME 78 : NFCMAX=IELBAS 79 : NFACET=NFCMAX 80 : NVOL=0 81 : NPTMAX=IK 82 : NPTINI=NPTMAX 83 : SEGINI IDCP 84 : DO 500 I=1,XCOOR(/1)/(IDIM+1) 85 : if (icpr(i).ne.0) IDCP(ICPR(I))=I 86 : 500 CONTINUE 87 : C REMPLIR IFUT 88 : DO 400 I=1,NFACET 89 : IFUT(I)=I 90 : 400 CONTINUE 91 : DO 300 IP=1,XCOOR(/1)/(IDIM+1) 92 : IPL=ICPR(IP) 93 : IF (IPL.EQ.0) GOTO 300 94 : IREF=4*(IP-1) 95 : DO 310 IC=1,3 96 : XYZ(IC,IPL)=XCOOR(IREF+IC) 97 : 310 CONTINUE 98 : 300 CONTINUE 99 : SEGSUP ICPR 100 : IF (IPREM.EQ.0) WRITE (IOIMP,*) 101 : # ' DEMETE VERSION 2.0.beta (C) CEA/SEMT - P VERPEAUX ' 102 : IPREM=1 103 : * WRITE (IOIMP,2000) NFCMAX,NFACET,NVOL,NPTMAX 104 : *2000 FORMAT (' DEMETE NFCMAX ',I5,' NFACET ',I5,' NVOL ',I5, 105 : * # ' NPTMAX ',I5) 106 : NPTBAS=XCOOR(/1)/(IDIM+1) 107 : WRITE(IOIMP,*) ' nptbas,nptini ',nptbas,nptini 107 : CALL DEMAIT(idcp,nptbas) 108 : IF (IERR.NE.0) GOTO 1100 109 : IF (NVOL.EQ.0) GOTO 1100 110 : WRITE (IOIMP,*) ' DEMETE MISSION ACCOMPLIE ' 111 : * WRITE (IOIMP,9702) NPTBAS,NPTINI,NPTMAX 112 : *9702 FORMAT(' DEMETE NPTBAS ',I5,' NPTINI ',I5,' NPTMAX ',I5) 113 : IF (NPTINI.EQ.NPTMAX) GOTO 5001 114 : NBPTA=XCOOR(/1)/4 115 : NBPTS=NBPTA+NPTMAX-NPTINI 116 : SEGADJ MCOORD 117 : DO 5000 I=NPTINI+1,NPTMAX 118 : DO 5010 J=1,4 119 : XCOOR(NBPTA*4+J)=XYZ(J,I) 120 : 5010 CONTINUE 121 : NBPTA=NBPTA+1 122 : 5000 CONTINUE 123 : 5001 CONTINUE 124 : NHE=0 125 : NPR=0 126 : NPY=0 127 : NTE=0 128 : DO 5800 I=1,NVOL 129 : IF (IVOL(9,I).NE.20) GOTO 5805 130 : NHE=NHE+1 131 : GOTO 5800 132 : 5805 IF (IVOL(9,I).NE.30) GOTO 5810 133 : NPR=NPR+1 134 : GOTO 5800 135 : 5810 IF (IVOL(9,I).NE.35) GOTO 5815 136 : NPY=NPY+1 137 : GOTO 5800 138 : 5815 IF (IVOL(9,I).NE.25) GOTO 5800 139 : NTE=NTE+1 140 : 5800 CONTINUE 141 : WRITE (IOIMP,50002) NHE,NPR,NPY,NTE 142 : 50002 FORMAT(' HEXAEDRES PRISMES PYRAMIDES TETRAEDRES ',4I6) 143 : C POUR EVITER LES ENNUIS AVEC L'OPTIMISEUR 144 : IPT1=IVOL 145 : IPT2=IVOL 146 : IPT3=IVOL 147 : IPT4=IVOL 148 : IPT5=IVOL 149 : NBS=0 150 : NBSOUS=0 151 : NBREF=0 152 : IF (NHE.EQ.0) GOTO 5900 153 : NBNN=8 154 : NBELEM=NHE 155 : SEGINI IPT1 156 : IPT5=IPT1 157 : IPT1.ITYPEL=14 158 : NBS=NBS+1 159 : 5900 IF (NPR.EQ.0) GOTO 5901 160 : NBNN=6 161 : NBELEM=NPR 162 : SEGINI IPT2 163 : IPT5=IPT2 164 : IPT2.ITYPEL=16 165 : NBS=NBS+1 166 : 5901 IF (NPY.EQ.0) GOTO 5902 167 : NBNN=5 168 : NBELEM=NPY 169 : SEGINI IPT3 170 : IPT5=IPT3 171 : IPT3.ITYPEL=25 172 : NBS=NBS+1 173 : 5902 IF (NTE.EQ.0) GOTO 5903 174 : NBNN=4 175 : NBELEM=NTE 176 : SEGINI IPT4 177 : IPT5=IPT4 178 : IPT4.ITYPEL=23 179 : NBS=NBS+1 180 : 5903 CONTINUE 181 : NHE=0 182 : NPR=0 183 : NPY=0 184 : NTE=0 185 : DO 6000 I=1,NVOL 186 : IF (IVOL(9,I).NE.20) GOTO 6010 187 : NHE=NHE+1 188 : IPT1.ICOLOR(NHE)=IDCOUL 189 : DO 6001 J=1,8 190 : IP=IVOL(J,I) 191 : IF (IP.LE.NPTINI) THEN 192 : IPT1.NUM(J,NHE)=IDCP(IP) 193 : ELSE 194 : IPT1.NUM(J,NHE)=IP-NPTINI+NPTBAS 195 : ENDIF 196 : 6001 CONTINUE 197 : GOTO 6000 198 : 6010 IF (IVOL(9,I).NE.30) GOTO 6020 199 : NPR=NPR+1 200 : IPT2.ICOLOR(NPR)=IDCOUL 201 : DO 6011 J=1,6 202 : IP=IVOL(J,I) 203 : IF (IP.LE.NPTINI) THEN 204 : IPT2.NUM(J,NPR)=IDCP(IP) 205 : ELSE 206 : IPT2.NUM(J,NPR)=IP-NPTINI+NPTBAS 207 : ENDIF 208 : 6011 CONTINUE 209 : GOTO 6000 210 : 6020 IF (IVOL(9,I).NE.35) GOTO 6030 211 : NPY=NPY+1 212 : IPT3.ICOLOR(NPY)=IDCOUL 213 : DO 6021 J=1,5 214 : IP=IVOL(J,I) 215 : IF (IP.LE.NPTINI) THEN 216 : IPT3.NUM(J,NPY)=IDCP(IP) 217 : ELSE 218 : IPT3.NUM(J,NPY)=IP-NPTINI+NPTBAS 219 : ENDIF 220 : 6021 CONTINUE 221 : GOTO 6000 222 : 6030 IF (IVOL(9,I).NE.25) GOTO 6000 223 : NTE=NTE+1 224 : IPT4.ICOLOR(NTE)=IDCOUL 225 : DO 6031 J=1,4 226 : IP=IVOL(J,I) 227 : IF (IP.LE.NPTINI) THEN 228 : IPT4.NUM(J,NTE)=IDCP(IP) 229 : ELSE 230 : IPT4.NUM(J,NTE)=IP-NPTINI+NPTBAS 231 : ENDIF 232 : 6031 CONTINUE 233 : 6000 CONTINUE 234 : IF (NBS.EQ.1) GOTO 6200 235 : NBREF=1 236 : NBELEM=0 237 : NBNN=0 238 : NBSOUS=NBS 239 : SEGINI MELEME 240 : LISREF(1)=IPT8 241 : NBS=0 242 : IF (NHE.EQ.0) GOTO 6100 243 : NBS=NBS+1 244 : LISOUS(NBS)=IPT1 245 : NBNN=IPT1.NUM(/1) 246 : NBELEM=IPT1.NUM(/2) 247 : SEGDES IPT1 248 : 6100 IF (NPR.EQ.0) GOTO 6101 249 : NBS=NBS+1 250 : LISOUS(NBS)=IPT2 251 : SEGDES IPT2 252 : 6101 IF (NPY.EQ.0) GOTO 6102 253 : NBS=NBS+1 254 : LISOUS(NBS)=IPT3 255 : SEGDES IPT3 256 : 6102 IF (NTE.EQ.0) GOTO 6103 257 : NBS=NBS+1 258 : LISOUS(NBS)=IPT4 259 : SEGDES IPT4 260 : 6103 CONTINUE 261 : SEGDES MELEME 262 : GOTO 1100 263 : 1100 SEGSUP IDCP 264 : GOTO 1020 265 : 6200 CONTINUE 266 : NBREF=1 267 : NBSOUS=0 268 : NBNN=IPT5.NUM(/1) 269 : NBELEM=IPT5.NUM(/2) 270 : SEGINI MELEME 271 : LISREF(1)=IPT8 272 : ITYPEL=IPT5.ITYPEL 273 : DO 6210 J=1,NBELEM 274 : ICOLOR(J)=IPT5.ICOLOR(J) 275 : DO 6210 I=1,NBNN 276 : NUM(I,J)=IPT5.NUM(I,J) 277 : 6210 CONTINUE 278 : SEGSUP IPT5 279 : SEGDES MELEME 280 : GOTO 1100 281 : 1000 SEGSUP ICPR 282 : 1020 SEGSUP NFC,NFV,NPF,IFUT,XYZ,IVOL,ICPR,IFAT 282 : IF (IDEGR.EQ.2) CALL DEMCHA(MELSUR,MELEME) 283 : RETURN 284 : END 285 : 286 : 287 :
© Cast3M 2003 - All rights reserved.
Disclaimer