1 : C PROVCC SOURCE GOUNAND 11/10/07 21:16:11 7150 2 : SUBROUTINE PROVCC(MCHPO1,MCHPO2,MLMOT1,MLMOT2,MLMOT3,MCHPO3) 3 : C----------------------------------------------------------------------- 4 : C PRODUIT VECTORIEL DE 2 CHPOINTS 5 : C----------------------------------------------------------------------- 6 : C EN STANDARD LE CHPOINT RESULTAT A POUR NUMERO D'HARMONIQUE 0 7 : C EN SERIE DE FOURIER , IL EST TYPE NOHARM 8 : C----------------------------------------------------------------------- 9 : C ENTREE 10 : C MCHPO1 CHPOINT 11 : C MLMOT1 LISTMOTS DE COMPOSANTES ASSOCIEES AU CHPOINT MCHPO1 12 : C Si 3D : 13 : C MCHPO2 CHPOINT 14 : C MLMOT2 LISTMOTS DE COMPOSANTES ASSOCIEES AU CHPOINT MCHPO2 15 : C MLMOT3 LISTMOTS DE COMPOSANTES ASSOCIEES AU CHPOINT RESULTAT 16 : C SORTIE 17 : C MCHPO3 POINTEUR SUR LE CHPOINT RESULTAT 18 : C----------------------------------------------------------------------- 19 : IMPLICIT INTEGER(I-N) 20 : IMPLICIT REAL*8(A-H,O-Z) 21 : -INC CCOPTIO 22 : -INC SMCHPOI 23 : -INC SMLMOTS 24 : -INC SMELEME 25 : -INC SMCOORD 26 : -INC TMTRAV 27 : CHARACTER*4 NOIN,NOMIL 28 : LOGICAL LDOUB 29 : SEGMENT ITRAV 30 : REAL*8 IVAA(NINC,NPOI),IVAB(NINC,NPOI) 31 : INTEGER IPOS(NINC),ICPRA(NPOI),ICPRB(NPOI) 32 : CHARACTER*4 INCA(NINC),INCB(NINC) 33 : ENDSEGMENT 34 : DATA NOMIL/'NOHA'/ 35 : * 36 : * On vérifie qu'il n'y a pas de doublons dans les LISTMOTS 37 : * donnés en entrée 38 : * 39 : LDOUB=.FALSE. 39 : CALL CUNIQ2(MLMOT1,MLMOT4) 39 : CALL CUNIQ2(MLMOT3,MLMOT6) 39 : IF (IDIM.EQ.3) CALL CUNIQ2(MLMOT2,MLMOT5) 40 : SEGACT,MLMOT1,MLMOT3,MLMOT4,MLMOT6 41 : IF (IDIM.EQ.3) SEGACT,MLMOT2,MLMOT5 42 : NINC1=MLMOT1.MOTS(/2) 43 : NINC3=MLMOT3.MOTS(/2) 44 : NINC4=MLMOT4.MOTS(/2) 45 : NINC6=MLMOT6.MOTS(/2) 46 : IF (IDIM.EQ.3) THEN 47 : NINC2=MLMOT2.MOTS(/2) 48 : NINC5=MLMOT5.MOTS(/2) 49 : ELSE 50 : NINC2=IDIM 51 : NINC5=IDIM 52 : ENDIF 53 : LDOUB=LDOUB.OR.(NINC1.NE.NINC4) 54 : LDOUB=LDOUB.OR.(NINC2.NE.NINC5) 55 : LDOUB=LDOUB.OR.(NINC3.NE.NINC6) 56 : SEGSUP,MLMOT4,MLMOT6 57 : IF (IDIM.EQ.3) SEGSUP,MLMOT5 58 : IF (LDOUB) THEN 59 : * 1019 2 60 : * Une donnée de type %m1:8 contient des doublons 61 : MOTERR(1:8)='LISTMOTS' 61 : CALL ERREUR(1019) 62 : RETURN 63 : ENDIF 64 : IF (NINC1.NE.IDIM.OR.NINC2.NE.IDIM.OR.NINC3.NE.IDIM) THEN 65 : * 1018 2 66 : * On attend un objet de type %m1:8 de dimension %i1 67 : MOTERR(1:8)='LISTMOTS' 68 : INTERR(1)=IDIM 68 : CALL ERREUR(1018) 69 : RETURN 70 : ENDIF 71 : IF (IDIM.EQ.3) GOTO 1000 72 : * 73 : * Cas simple (2D) 74 : * 75 : SEGINI,MCHPO3=MCHPO1 76 : NSOUPO=0 77 : SEGACT MCHPO1 78 : NSOUP1=MCHPO1.IPCHP(/1) 79 : DO 30 ISOUP1=1,NSOUP1 80 : MSOUP1=MCHPO1.IPCHP(ISOUP1) 81 : SEGACT MSOUP1 82 : NC1=MSOUP1.NOHARM(/1) 83 : NX=0 84 : NY=0 85 : * WRITE(IOIMP,*) 'MOTS1=',MLMOT1.MOTS(1)(1:4) 86 : * WRITE(IOIMP,*) 'MOTS2=',MLMOT1.MOTS(2)(1:4) 87 : DO IC1=1,NC1 88 : * WRITE(IOIMP,*) 'NOCOMP1=',MSOUP1.NOCOMP(IC1) 89 : IF (MSOUP1.NOCOMP(IC1).EQ.MLMOT1.MOTS(1)(1:4)) NX=IC1 90 : IF (MSOUP1.NOCOMP(IC1).EQ.MLMOT1.MOTS(2)(1:4)) NY=IC1 91 : ENDDO 92 : NC=0 93 : IF (NX.NE.0) NC=NC+1 94 : IF (NY.NE.0) NC=NC+1 95 : * WRITE(IOIMP,*) 'NX=',NX 96 : * WRITE(IOIMP,*) 'NY=',NY 97 : IF (NC.EQ.0) GOTO 29 98 : SEGINI MSOUP3 99 : MPOVA1=MSOUP1.IPOVAL 100 : SEGACT MPOVA1 101 : N=MPOVA1.VPOCHA(/1) 102 : SEGINI MPOVA3 103 : IC=0 104 : IF (NY.NE.0) THEN 105 : IC=IC+1 106 : * WRITE(IOIMP,*) 'IC=',IC,' ',MLMOT3.MOTS(1)(1:4) 107 : MSOUP3.NOCOMP(IC)=MLMOT3.MOTS(1)(1:4) 108 : MSOUP3.NOCONS(IC)=MSOUP1.NOCONS(NY) 109 : MSOUP3.NOHARM(IC)=MSOUP1.NOHARM(NY) 110 : DO I=1,N 111 : MPOVA3.VPOCHA(I,IC)=-1*MPOVA1.VPOCHA(I,NY) 112 : ENDDO 113 : ENDIF 114 : IF (NX.NE.0) THEN 115 : IC=IC+1 116 : * WRITE(IOIMP,*) 'IC=',IC,' ',MLMOT3.MOTS(2)(1:4) 117 : MSOUP3.NOCOMP(IC)=MLMOT3.MOTS(2)(1:4) 118 : MSOUP3.NOCONS(IC)=MSOUP1.NOCONS(NX) 119 : MSOUP3.NOHARM(IC)=MSOUP1.NOHARM(NX) 120 : DO I=1,N 121 : MPOVA3.VPOCHA(I,IC)=MPOVA1.VPOCHA(I,NX) 122 : ENDDO 123 : ENDIF 124 : SEGDES MPOVA3 125 : SEGDES MPOVA1 126 : MSOUP3.IGEOC=MSOUP1.IGEOC 127 : MSOUP3.IPOVAL=MPOVA3 128 : SEGDES MSOUP3 129 : NSOUPO=NSOUPO+1 130 : MCHPO3.IPCHP(NSOUPO)=MSOUP3 131 : 29 CONTINUE 132 : SEGDES MSOUP1 133 : 30 CONTINUE 134 : SEGDES MCHPO1 135 : NAT=MCHPO3.JATTRI(/1) 136 : SEGADJ MCHPO3 137 : SEGDES MCHPO3 138 : SEGDES MLMOT1,MLMOT3 139 : RETURN 140 : * 141 : * Cas dimension 3 repris de la subroutine PROSCAL 142 : * 143 : 1000 CONTINUE 144 : NPOI=XCOOR(/1)/(IDIM+1) 145 : MLMOTS=MLMOT1 146 : SEGACT MLMOTS 147 : NINC= MOTS(/2) 148 : SEGINI ITRAV 149 : DO 1 I = 1, NINC 150 : INCA(I)=MOTS(I) 151 : 1 CONTINUE 152 : SEGDES MLMOTS 153 : MLMOTS=MLMOT2 154 : SEGACT MLMOTS 155 : IF(MOTS(/2).NE.NINC) THEN 156 : SEGDES MLMOTS 157 : SEGSUP ITRAV 158 : MOTERR(1:4)='PVEC' 159 : MOTERR(5:12)='LISTMOTS' 159 : CALL ERREUR(125) 160 : RETURN 161 : ENDIF 162 : DO 21 I = 1, NINC 163 : INCB(I)=MOTS(I) 164 : 21 CONTINUE 165 : SEGDES MLMOTS 166 : C 167 : C ********* IVAA CONTIENDRA LES VALEURS A MULTIPLIER PAR IVAB 168 : C ********* CREATION D'ABORD DE IVAA PUIS DE IVAB 169 : C 170 : MCHPOI=MCHPO1 171 : SEGACT MCHPOI 172 : NSOUPO = IPCHP(/1) 173 : DO 2 M = 1,NSOUPO 174 : MSOUPO = IPCHP(M) 175 : SEGACT MSOUPO 176 : NC=NOCOMP(/2) 177 : DO 10 I = 1,NINC 178 : IPOS(I)=0 179 : 10 CONTINUE 180 : DO 4 K = 1, NINC 181 : DO 3 J = 1, NC 182 : NOIN= NOCOMP (J) 183 : IF(INCA(K). EQ . NOIN) THEN 184 : IPOS(K)=J 185 : GO TO 4 186 : ENDIF 187 : 3 CONTINUE 188 : 4 CONTINUE 189 : DO 5 I = 1,NINC 190 : IF(IPOS(I). NE . 0) GO TO 6 191 : 5 CONTINUE 192 : GO TO 8 193 : 6 CONTINUE 194 : MELEME=IGEOC 195 : SEGACT MELEME 196 : NBELEM=NUM(/2) 197 : MPOVAL=IPOVAL 198 : SEGACT MPOVAL 199 : DO 9 LI = 1,NINC 200 : KL = IPOS(LI) 201 : IF(KL.EQ.0) GO TO 9 202 : DO 7 I = 1,NBELEM 203 : I1 = NUM(1,I) 204 : IVAA(LI,I1)=VPOCHA(I,KL) 205 : ICPRA(I1)=1 206 : 7 CONTINUE 207 : 9 CONTINUE 208 : SEGDES MELEME,MPOVAL 209 : 8 CONTINUE 210 : SEGDES MSOUPO 211 : 2 CONTINUE 212 : SEGDES MCHPOI 213 : C 214 : C TRAITEMENT DU 2-EME CHPOINT 215 : C 216 : IA=0 217 : MCHPOI=MCHPO2 218 : SEGACT MCHPOI 219 : NSOUPO = IPCHP(/1) 220 : DO 12 M = 1,NSOUPO 221 : MSOUPO = IPCHP(M) 222 : SEGACT MSOUPO 223 : NC=NOCOMP(/2) 224 : DO 11 I = 1,NINC 225 : IPOS(I)=0 226 : 11 CONTINUE 227 : DO 14 K= 1,NINC 228 : DO 13 J = 1, NC 229 : NOIN= NOCOMP (J) 230 : IF(INCB(K). EQ . NOIN) THEN 231 : IPOS(K)=J 232 : GO TO 14 233 : ENDIF 234 : 13 CONTINUE 235 : 14 CONTINUE 236 : DO 15 I = 1,NINC 237 : IF(IPOS(I). NE . 0) GO TO 16 238 : 15 CONTINUE 239 : GO TO 18 240 : 16 CONTINUE 241 : MELEME=IGEOC 242 : SEGACT MELEME 243 : NBELEM=NUM(/2) 244 : MPOVAL=IPOVAL 245 : SEGACT MPOVAL 246 : DO 19 LI = 1,NINC 247 : KL = IPOS(LI) 248 : IF(KL.EQ.0) GO TO 19 249 : DO 17 I = 1,NBELEM 250 : I1 = NUM(1,I) 251 : IVAB(LI,I1)=VPOCHA(I,KL) 252 : IF(ICPRA(I1).NE.0) THEN 253 : IA=IA+1 254 : ICPRB(I1)=IA 255 : ENDIF 256 : 17 CONTINUE 257 : 19 CONTINUE 258 : SEGDES MELEME,MPOVAL 259 : 18 CONTINUE 260 : SEGDES MSOUPO 261 : 12 CONTINUE 262 : IF(IA.EQ.0) THEN 263 : C 264 : C CHPOINT VIDE 265 : C 266 : SEGSUP ITRAV 267 : SEGDES MCHPOI 268 : NSOUPO=0 269 : NAT=1 270 : SEGINI MCHPOI 271 : IFOPOI=IFOUR 272 : SEGDES MCHPOI 273 : MCHPO3=MCHPOI 274 : RETURN 275 : ENDIF 276 : C 277 : C ON EFFECTUE LE CALCUL 278 : C 279 : NNIN=3 280 : NNNOE=IA 281 : SEGINI MTRAV 282 : SEGACT MLMOT3 283 : DO I=1,3 284 : INCO(I)=MLMOT3.MOTS(I) 285 : ENDDO 286 : SEGDES MLMOT3 287 : * 288 : * MODIF MILL LE 18 / 7 / 90 289 : * REMPLISSAGE DE L'HARMONIQUE : NOHARM SI FOURIER , 0 SINON 290 : * 291 : IF(IFOPOI.EQ.1) THEN 292 : READ(NOMIL,FMT='(A4)') NHMIL 293 : DO I=1,3 294 : NHAR(1)=NHMIL 295 : ENDDO 296 : ENDIF 297 : * 298 : MCHPOI=MCHPO1 299 : SEGACT MCHPOI 300 : NSOUPO=IPCHP(/1) 301 : DO 22 M=1,NSOUPO 302 : MSOUPO=IPCHP(M) 303 : SEGACT MSOUPO 304 : MELEME=IGEOC 305 : SEGACT MELEME 306 : DO 27 J=1,NUM(/2) 307 : I1=NUM(1,J) 308 : IB=ICPRB(I1) 309 : IF(IB.EQ.0) GO TO 27 310 : IF(IGEO(IB).NE.0) GO TO 27 311 : IGEO(IB)=I1 312 : DO 28 LI=1,NINC 313 : IBIN(LI,IB)=1 314 : 28 CONTINUE 315 : BB(1,IB)=BB(1,IB)+IVAA(2,I1)*IVAB(3,I1) 316 : $ -IVAA(3,I1)*IVAB(2,I1) 317 : BB(2,IB)=BB(2,IB)+IVAA(3,I1)*IVAB(1,I1) 318 : $ -IVAA(1,I1)*IVAB(3,I1) 319 : BB(3,IB)=BB(3,IB)+IVAA(1,I1)*IVAB(2,I1) 320 : $ -IVAA(2,I1)*IVAB(1,I1) 321 : 27 CONTINUE 322 : SEGDES MELEME,MSOUPO 323 : 22 CONTINUE 324 : SEGDES MCHPOI 325 : SEGSUP ITRAV 325 : CALL CRECHP(MTRAV,MCHPO3) 326 : SEGSUP MTRAV 327 : RETURN 328 : END 329 : 330 : 331 : 332 : 333 :
© Cast3M 2003 - All rights reserved.
Disclaimer