1 : C PRSURF SOURCE CHAT 07/10/29 21:26:34 5940 2 : C CE SOUS PROGRAMME SERT D'INTERFACE POUR LE SOUS PROGRAMME TRANSF 3 : C IL PREPARE SES DONNEES ET PROJETTE LES POINTS SUR UN PLAN 4 : C 5 : SUBROUTINE PRSURF 6 : IMPLICIT INTEGER(I-N) 7 : IMPLICIT REAL*8 (A-H,O-Z) 8 : -INC SMELEME 9 : -INC CCOPTIO 10 : -INC CCGEOME 11 : -INC SMCOORD 12 : real*8 tcval(13) 13 : SEGMENT XPROJ(3,1) 14 : SEGMENT /FER/(NFI(ITT),MAI(IPP),ITOUR) 15 : SEGMENT/SAUV/(NSA(MAI(ITOUR+1))) 16 : PARAMETER (LCAS = 6) 17 : DIMENSION ITEST(0:15) 18 : CHARACTER*4 MCLE(6) 19 : DATA MCLE/'PLAN','SPHE','CYLI','CONI','TORI','POLY'/ 20 : isens=0 21 : msurfp=0 22 : DO 2 I=0,15 23 : 2 ITEST(I)=0 24 : IOBL=IDIM-2 25 : NBCAS=6 26 : IF (IDIM.EQ.2) NBCAS=1 26 : CALL MESLIR(-230) 27 : ICOND=1 28 : IF (IDIM.EQ.2) ICOND=0 28 : CALL LIRMOT(MCLE,NBCAS,ICAS,ICOND) 29 : IF (IERR.GT.1) RETURN 30 : IF (IDIM.EQ.2) ICAS=1 31 : IF (ICAS .EQ. 6) THEN 31 : CALL SURFP1 ('SURF',IBID,IBID,IBID,IBID,IPT1,msurfp) 32 : ELSE 32 : CALL MESLIR(-229) 32 : CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU) 32 : CALL MESLIR(-228) 32 : IF (ICAS.GT.1) CALL LIROBJ('POINT ',IP1,1,IRETOU) 32 : CALL MESLIR(-227) 32 : IF (ICAS.GT.2) CALL LIROBJ('POINT ',IP2,1,IRETOU) 32 : CALL MESLIR(-226) 32 : IF (ICAS.EQ.5) CALL LIROBJ('POINT ',IP3,1,IRETOU) 33 : END IF 34 : IF (IERR.NE.0) RETURN 35 : IPCON=IPT1 36 : SEGACT IPT1 36 : IF (KSURF(IPT1.ITYPEL).NE.0) CALL ERREUR(16) 37 : IF (IERR.GT.1) RETURN 38 : IPT5=1 38 : CALL AVTRSF(IPT1,FER,IPT5) 39 : IF (IERR.GT.1) RETURN 40 : DO 12 I=1,IPT1.NUM(/2) 41 : ITEST(IPT1.ICOLOR(I))=1 42 : 12 CONTINUE 43 : ICHCOL=-1 44 : DO 14 I=0,15 45 : IF (ITEST(I).EQ.1) THEN 46 : IF (ICHCOL.EQ.-1) THEN 47 : ICHCOL=I 48 : ELSE 49 : ICHCOL=ITABM(ICHCOL,I) 50 : ENDIF 51 : ENDIF 52 : 14 CONTINUE 53 : SEGDES IPT1 54 : SEGINI SAUV 55 : DO 60 I=1,NSA(/1) 56 : 60 NSA(I)=NFI(I) 57 : ichp=0 58 : * Lecture chpoin de densite 58 : call lirobj('CHPOINT',ichp,0,iretou) 58 : if (ichp.ne.0) call menfor(ichp,fer) 58 : IF(ICAS.EQ.1)CALL PPLAN(1,FER,XPROJ ,NDEB,NUMNP,tcval) 58 : IF(ICAS.EQ.2)CALL PSPHE(1,FER,XPROJ ,NDEB,NUMNP,IP1,tcval) 58 : IF(ICAS.EQ.3)CALL PCYLI(1,FER,XPROJ ,NDEB,NUMNP,IP1,IP2, 59 : $ tcval,isens) 59 : IF(ICAS.EQ.4)CALL PCONE(1,FER,XPROJ ,NDEB,NUMNP,IP1,IP2, 60 : $ tcval,isens) 60 : IF(ICAS.EQ.5)CALL PTORI(1,FER,XPROJ,NDEB,NUMNP,IP1,IP2,IP3,tcval, 61 : $ isens) 61 : IF(ICAS.EQ.6)CALL SURFP5 (FER,XPROJ,NDEB,msurfp) 62 : IF (IERR.GT.1) RETURN 62 : if (ichp.ne.0) call menfo2(ichp,fer,xproj) 63 : DO 84, NUCOT = 1, ITOUR 64 : * 65 : IDEB = MAI(NUCOT) 66 : IFIN = MAI(NUCOT+1)-1 67 : * 68 : DO 84, IP2 = IDEB, IFIN 69 : * 70 : * 71 : 84 CONTINUE 72 : 73 : 74 : * cas du maillage polygonal ==> dualisation 74 : if (ILCOUR.eq.32) call dualis(fer,ifer,xproj,iproj) 74 : CALL PRAJUS(FER,XPROJ,IPT2,NUMELG,NUMNP,ichp) 75 : IF (IERR.GT.1) RETURN 76 : IF (ICAS .EQ. 6) THEN 77 : ID1=XCOOR(/1)/(IDIM+1) 77 : CALL SURFP6 ('SURF',XPROJ,NDEB,NUMNP,0,msurfp) 77 : CALL AMELI1 (IPT2,SAUV,ID1,NDEB,NUMNP,NUMELG) 78 : NDEB = NUMNP + 1 79 : END IF 80 : * 81 : * Cas du maillage polygonal ==> dualisation 82 : * 83 : IF (ILCOUR.eq.32) THEN 83 : call duali2(ifer,xproj,iproj,ipt2,numelg,ndeb,numnp) 84 : ELSE 85 : IPT2.ITYPEL=4 86 : IF (KSURF(ILCOUR).GE.8) IPT2.ITYPEL=8 87 : ITY=IPT2.ITYPEL 88 : IF (KSURF(ILCOUR).EQ.6.OR.KSURF(ILCOUR).EQ.10) ITY=ITY+2 88 : CALL CHANGS(NUMNP,NUMELG,ITY,IPT2,XPROJ,IPT5) 89 : ENDIF 90 : ID1=XCOOR(/1)/(IDIM+1) 90 : IF(ICAS.EQ.1)CALL PPLAN(2,FER,XPROJ ,NDEB,NUMNP,tcval) 90 : IF(ICAS.EQ.2)CALL PSPHE(2,FER,XPROJ ,NDEB,NUMNP,IP1,tcval) 90 : IF(ICAS.EQ.3)CALL PCYLI(2,FER,XPROJ ,NDEB,NUMNP,IP1,IP2, 91 : $ tcval,isens) 91 : IF(ICAS.EQ.4)CALL PCONE(2,FER,XPROJ ,NDEB,NUMNP,IP1,IP2, 92 : $ tcval,isens) 92 : IF(ICAS.EQ.5)CALL PTORI(2,FER,XPROJ,NDEB,NUMNP,IP1,IP2,IP3,tcval, 93 : $ isens) 93 : IF(ICAS.EQ.6)CALL SURFP6 ('SURF',XPROJ,NDEB,NUMNP,1,msurfp) 94 : IF (KSURF(ILCOUR).GE.8) GOTO 100 95 : NBNN=IPT2.NUM(/1) 96 : NBREF=1 97 : NBSOUS=0 98 : NBELEM=NUMELG 99 : SEGINI IPT1 100 : IDEC=ID1-NDEB+1 101 : DO 50 J=1,NBELEM 102 : IPT1.ICOLOR(J)=ICHCOL 103 : DO 50 I=1,NBNN 104 : IANC=IPT2.NUM(I,J) 105 : IF (IANC.GE.NDEB) GOTO 61 106 : IPT1.NUM(I,J)=NSA(IANC) 107 : GOTO 50 108 : 61 IPT1.NUM(I,J)=IANC+IDEC 109 : 50 CONTINUE 110 : SEGSUP SAUV 111 : IPT1.ITYPEL=IPT2.ITYPEL 112 : SEGSUP IPT2 113 : 200 CONTINUE 114 : * IPT5=IPCON PARAIT INUTILE PV | 115 : * SEGINI ,IPT6=IPT5 116 : * DO 210 I=1,IPT6.NUM(/2) 117 : *210 IPT6.ICOLOR(I)=ICHCOL 118 : * IPT1.LISREF(1)=IPT6 119 : IPT1.LISREF(1)=IPCON 119 : CALL ECROBJ('MAILLAGE',IPT1) 120 : SEGDES IPT1 121 : RETURN 122 : 100 CONTINUE 123 : * 124 : IF (ILCOUR .EQ. 32) THEN 125 : * 126 : * Polygone 127 : * 128 : IPT1 = IPT2 129 : NBSOUS=IPT1.LISOUS(/1) 130 : IDEC=ID1-NDEB+1 131 : NBELEM=0 132 : NBNN=0 133 : NBREF=1 134 : SEGADJ IPT1 135 : IPT1.LISREF(1)= IPCON 136 : DO 80, NTEL = 1, IPT1.LISOUS(/1) 137 : IPT3 = IPT1.LISOUS(NTEL) 138 : NBELEM = IPT3.NUM(/2) 139 : DO 80, NBEL = 1, NBELEM 140 : IPT3.ICOLOR(NBEL) = ICHCOL 141 : DO 80, NUN = 1, IPT3.NUM(/1) 142 : IANC=IPT3.NUM(NUN,NBEL) 143 : IF (IANC .GE.NDEB) THEN 144 : IPT3.NUM(NUN,NBEL)=IANC+IDEC 145 : ELSE 146 : IPT3.NUM(NUN,NBEL)=NSA(IANC) 147 : ENDIF 148 : 80 CONTINUE 148 : CALL ECROBJ('MAILLAGE',IPT1) 149 : DO 85, NTEL = 1, IPT1.LISOUS(/1) 150 : IPT3 = IPT1.LISOUS(NTEL) 151 : SEGDES IPT3 152 : 85 CONTINUE 153 : SEGDES IPT1 154 : RETURN 155 : * 156 : ENDIF 157 : C ON A DES CARRES ET DES TRIANGLES 158 : NBRE=IPT2.NUM(/1) 159 : IDEC=ID1-NDEB+1 160 : NBSOUS=0 161 : NBREF=0 162 : NBTRI=0 163 : DO 101 I=1,NUMELG 164 : IF (IPT2.NUM(NBRE,I).NE.0) GOTO 101 165 : NBTRI=NBTRI+1 166 : 101 CONTINUE 167 : NBELEM=NBTRI 168 : IF (NBTRI.EQ.NUMELG) NBREF=1 169 : NBNN=3 170 : IF (NBTRI.EQ.0) GOTO 104 171 : IF (NBRE.EQ.8) NBNN=6 172 : NBNNT=NBNN 173 : SEGINI IPT3 174 : C A CAUSE DE L'OPTIMISEUR IBM (POUR AVOIR IPT4<>0) 175 : IPT4=IPT3 176 : IPT3.ITYPEL=4 177 : IF (NBRE.EQ.8) IPT3.ITYPEL=6 178 : 104 CONTINUE 179 : NBNN=NBRE 180 : NBNNQ=NBNN 181 : NBELEM=NUMELG-NBTRI 182 : IF (NBELEM.EQ.0) GOTO 105 183 : IF (NBELEM.EQ.NUMELG) NBREF=1 184 : SEGINI IPT4 185 : C TOUJOURS L'OPTIMISEUR 186 : IF (NBTRI.EQ.0) IPT3=IPT4 187 : IPT4.ITYPEL=8 188 : IF (NBRE.EQ.8) IPT4.ITYPEL=10 189 : 105 CONTINUE 190 : J=0 191 : K=0 192 : DO 102 I=1,NUMELG 193 : IF (IPT2.NUM(NBRE,I).NE.0) GOTO 103 194 : J=J+1 195 : IPT3.ICOLOR(J)=ICHCOL 196 : DO 110 L=1,NBNNT 197 : IANC=IPT2.NUM(L,I) 198 : IF (IANC.GE.NDEB) GOTO 111 199 : IPT3.NUM(L,J)=NSA(IANC) 200 : GOTO 110 201 : 111 IPT3.NUM(L,J)=IANC+IDEC 202 : 110 CONTINUE 203 : GOTO 102 204 : 103 K=K+1 205 : IPT4.ICOLOR(K)=ICHCOL 206 : DO 120 L=1,NBNNQ 207 : IANC=IPT2.NUM(L,I) 208 : IF (IANC.GE.NDEB) GOTO 121 209 : IPT4.NUM(L,K)=NSA(IANC) 210 : GOTO 120 211 : 121 IPT4.NUM(L,K)=IANC+IDEC 212 : 120 CONTINUE 213 : 102 CONTINUE 214 : SEGSUP IPT2,SAUV 215 : IF (NBTRI.NE.0) SEGDES IPT3 216 : IF (NBELEM.NE.0) SEGDES IPT4 217 : NBNN=0 218 : NBQUA=NBELEM 219 : NBELEM=0 220 : NBSOUS=0 221 : IF (NBTRI.NE.0) NBSOUS=NBSOUS+1 222 : IF (NBQUA.NE.0) NBSOUS=NBSOUS+1 223 : IF (NBSOUS.EQ.1) GOTO 180 224 : NBREF=1 225 : SEGINI IPT1 226 : ISOUS=0 227 : IF (NBTRI.EQ.0) GOTO 171 228 : ISOUS=ISOUS+1 229 : IPT1.LISOUS(ISOUS)=IPT3 230 : 171 CONTINUE 231 : IF (NBQUA.EQ.0) GOTO 172 232 : ISOUS=ISOUS+1 233 : IPT1.LISOUS(ISOUS)=IPT4 234 : 172 CONTINUE 235 : GOTO 200 236 : 180 CONTINUE 237 : IF (NBTRI.NE.0) IPT1=IPT3 238 : IF (NBQUA.NE.0) IPT1=IPT4 239 : SEGACT IPT1*MOD 240 : IPT1.LISREF(1)=IPCON 241 : GOTO 200 242 : END 243 : 244 : 245 : 246 : 247 : 248 : 249 : 250 : 251 : 252 : 253 : 254 : 255 :
© Cast3M 2003 - All rights reserved.
Disclaimer