1 : C POLA1 SOURCE CHAT 11/03/16 21:29:12 6902 2 : SUBROUTINE POLA1(IPMODL,IPCHE1,IPCHE2,IPCHE3,IMIL) 3 : *--------------------------------------------------------------------- 4 : * 5 : * CALCUL DE LA DECOMPOSITION POLAIRE 6 : * (APPELE PAR POLA) 7 : * 8 : * ENTREES: 9 : * -------- 10 : * 11 : * IPMODL POINTEUR SUR UN MMODEL 12 : * IPCHE1 POINTEUR SUR UN CHAMELEM DE GRADIENTS 13 : * (TYPE MCHAML) 14 : * IMIL INDICATEUR DEPL OU GEOM SELON QUE LE 15 : * GRADIENT EST CELUI D'UN DEPLACEMENT 16 : * OU D'UNE GEOMETRIE 17 : * 18 : * SORTIES : 19 : * --------- 20 : * 21 : * IPCHE2 POINTEUR SUR UN CHAMELEM R 22 : * IPCHE3 POINTEUR SUR UN CHAMELEM U 23 : * 24 : *--------------------------------------------------------------------- 25 : * 26 : IMPLICIT INTEGER(I-N) 27 : IMPLICIT REAL*8(A-H,O-Z) 28 : -INC CCOPTIO 29 : -INC CCHAMP 30 : -INC SMCHAML 31 : -INC SMMODEL 32 : * 33 : SEGMENT NOTYPE 34 : CHARACTER*16 TYPE(NBTYPE) 35 : ENDSEGMENT 36 : * 37 : SEGMENT MPTVAL 38 : INTEGER IPOS(NS) ,NSOF(NS) 39 : INTEGER IVAL(NCOSOU) 40 : CHARACTER*16 TYVAL(NCOSOU) 41 : ENDSEGMENT 42 : * 43 : PARAMETER ( NINF=3 ) 44 : INTEGER INFOS(NINF) 45 : CHARACTER*(NCONCH) CONM 46 : LOGICAL lsupgd 47 : * 48 : DIMENSION F(9),R(9),U(9) 49 : 50 : NHRM=NIFOUR 51 : * 52 : MCHELM=IPCHE1 53 : SEGACT MCHELM 54 : IF(TITCHE.NE.'GRADIENT') THEN 55 : MOTERR(1:8)='GRADIENT' 55 : CALL ERREUR(145) 56 : GOTO 666 57 : ENDIF 58 : * 59 : * ... VERIFICATION DU LIEU SUPPORT DU MCHAML DE GRADIENT 60 : * 61 : N1=INFCHE(/1) 62 : N3=INFCHE(/2) 63 : IF(N3.LT.6) THEN 64 : ISUP1=1 65 : ELSE 66 : ISUP1=INFCHE(1,6) 67 : DO 1000 ISCHAM=2,N1 68 : IF(INFCHE(ISCHAM,6).NE.ISUP1) THEN 68 : CALL ERREUR(560) 69 : SEGDES,MCHELM 70 : RETURN 71 : ENDIF 72 : 1000 CONTINUE 73 : ENDIF 74 : * 75 : * ... ACTIVATION DU MODELE ... 76 : * 77 : MMODEL=IPMODL 78 : SEGACT MMODEL 79 : NSOUS=KMODEL(/1) 80 : 81 : C ... Initialisation des deux nouveaux MCHELM - résultats ... 82 : C les MCHAML resultats sont types GRADIENT pour simplifier 83 : C la gestion des noms des composantes 84 : C 85 : 86 : N1=NSOUS 87 : L1=8 88 : N3=6 89 : * 90 : SEGINI MCHEL1 91 : IPCHE2=MCHEL1 92 : MCHEL1.IFOCHE=IFOUR 93 : MCHEL1.TITCHE='GRADIENT' 94 : * 95 : SEGINI MCHEL2 96 : IPCHE3=MCHEL2 97 : MCHEL2.IFOCHE=IFOUR 98 : MCHEL2.TITCHE='GRADIENT' 99 : * 100 : * ... BOUCLE SUR LES SOUS ZONES DU MODELE ... 101 : * 102 : DO 200 ISOUS=1,NSOUS 103 : * 104 : * ... INITIALISATION ... 105 : * 106 : NCOMP=0 107 : IVACOM = 0 108 : MOCOMP = 0 109 : IVAGR1 = 0 110 : IVAGR2 = 0 111 : IMODEL=KMODEL(ISOUS) 112 : SEGACT IMODEL 113 : * 114 : IPMAIL=IMAMOD 115 : CONM =CONMOD 116 : MELE =NEFMOD 117 : C 118 : C ... COQUE INTEGREE OU PAS ? ... 119 : C 120 : IF(INFMOD(/1).NE.0)THEN 121 : NPINT=INFMOD(1) 122 : ELSE 123 : NPINT=0 124 : ENDIF 125 : IF (NPINT.NE.0)THEN 125 : CALL ERREUR(615) 126 : SEGDES IMODEL,MMODEL 127 : SEGSUP MCHEL1,MCHEL2 128 : GOTO 666 129 : ENDIF 130 : * 131 : * ... INFORMATION SUR L'ELEMENT FINI ... 132 : * 132 : * CALL ELQUOI(MELE,0,ISUP1,IPINF,IMODEL) 133 : IF (IERR.NE.0) THEN 134 : SEGDES IMODEL,MMODEL 135 : SEGSUP MCHEL1,MCHEL2 136 : GOTO 666 137 : ENDIF 138 : * 139 : * INFO =IPINF 140 : MFR =INFELE(13) 141 : * MINTE =INFELE(11) 142 : minte=infmod(2+isup1) 143 : * 144 : * ... Verfication de compatibilité des MCHAML du point de vue des 145 : * tableaux INFCHE et remplissage du tableau INFOS pour COMCHA ... 146 : * 146 : CALL IDENT(IPMAIL,CONM,IPCHE1,0,INFOS,IRTD) 147 : IF (IRTD.EQ.0) THEN 148 : SEGDES IMODEL,MMODEL 149 : SEGSUP MCHEL1,MCHEL2 150 : * SEGSUP INFO 151 : GOTO 666 152 : ENDIF 153 : * 154 : * ... Les attributs de chaque sous-zone ... 155 : * 156 : MCHEL1.INFCHE(ISOUS,1)=0 157 : MCHEL1.INFCHE(ISOUS,2)=0 158 : MCHEL1.INFCHE(ISOUS,3)=NHRM 159 : MCHEL1.INFCHE(ISOUS,4)=MINTE 160 : MCHEL1.INFCHE(ISOUS,5)=0 161 : MCHEL1.INFCHE(ISOUS,6)=ISUP1 162 : MCHEL1.IMACHE(ISOUS)=IPMAIL 163 : MCHEL1.CONCHE(ISOUS)=CONMOD 164 : * 165 : MCHEL2.INFCHE(ISOUS,1)=0 166 : MCHEL2.INFCHE(ISOUS,2)=0 167 : MCHEL2.INFCHE(ISOUS,3)=NHRM 168 : MCHEL2.INFCHE(ISOUS,4)=MINTE 169 : MCHEL2.INFCHE(ISOUS,5)=0 170 : MCHEL2.INFCHE(ISOUS,6)=ISUP1 171 : MCHEL2.IMACHE(ISOUS)=IPMAIL 172 : MCHEL2.CONCHE(ISOUS)=CONMOD 173 : * 174 : * ... RECHERCHE DES NOMS de COMPOSANTES ... 175 : * 176 : if(lnomid(3).ne.0) then 177 : nomid=lnomid(3) 178 : segact nomid 179 : mocomp=nomid 180 : ncomp=lesobl(/2) 181 : nfac=lesfac(/2) 182 : lsupgd=.false. 183 : else 184 : lsupgd=.true. 184 : CALL IDGRAD(MFR,IFOUR,MOCOMP,NCOMP,NFAC) 185 : endif 186 : * 187 : * ... VERIFICATION DE LEUR PRESENCE ... 188 : * 189 : NBTYPE=1 190 : SEGINI NOTYPE 191 : MOTYPE=NOTYPE 192 : TYPE(1)='REAL*8' 192 : CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCOMP,MOTYPE,1,INFOS,3,IVACOM) 193 : SEGSUP NOTYPE 194 : IF (IERR.NE.0) THEN 195 : IVASC1=0 196 : IVASC2=0 197 : GOTO 9990 198 : ENDIF 199 : * 200 : * ... RECHERCHE DA LA TAILLE DES MELVAL A ALLOUER ... 201 : * 202 : N1PTEL=0 203 : N1EL=0 204 : MPTVAL=IVACOM 205 : DO 110 ICOMP=1,NCOMP 206 : MELVAL=IVAL(ICOMP) 207 : N1PTEL=MAX(N1PTEL,VELCHE(/1)) 208 : N1EL =MAX(N1EL ,VELCHE(/2)) 209 : 110 CONTINUE 210 : N2PTEL=0 211 : N2EL=0 212 : * 213 : * ... Création et stockage des MCHAML ... 214 : * 215 : N2=NCOMP 216 : SEGINI MCHAM1 217 : MCHEL1.ICHAML(ISOUS)=MCHAM1 218 : SEGINI MCHAM2 219 : MCHEL2.ICHAML(ISOUS)=MCHAM2 220 : * 221 : C ... et des MELVAL de la zone élémentaire ... 222 : C 223 : NS=1 224 : NCOSOU=NCOMP 225 : SEGINI MPTVAL 226 : IVAGR1=MPTVAL 227 : NOMID=MOCOMP 228 : SEGACT NOMID 229 : DO 71 ICOMP=1,NCOMP 230 : MCHAM1.TYPCHE(ICOMP)='REAL*8' 231 : MCHAM1.NOMCHE(ICOMP)=LESOBL(ICOMP) 232 : SEGINI MELVAL 233 : MCHAM1.IELVAL(ICOMP)=MELVAL 234 : IVAL(ICOMP)=MELVAL 235 : 71 CONTINUE 236 : * 237 : SEGINI MPTVAL 238 : IVAGR2=MPTVAL 239 : NOMID=MOCOMP 240 : SEGACT NOMID 241 : DO 72 ICOMP=1,NCOMP 242 : MCHAM2.TYPCHE(ICOMP)='REAL*8' 243 : MCHAM2.NOMCHE(ICOMP)=LESOBL(ICOMP) 244 : SEGINI MELVAL 245 : MCHAM2.IELVAL(ICOMP)=MELVAL 246 : IVAL(ICOMP)=MELVAL 247 : 72 CONTINUE 248 : * 249 : * 250 : ********************************************************************** 251 : * * 252 : * BRANCHEMENT SUIVANT LA DIMENSION * 253 : * * 254 : ********************************************************************** 255 : * 256 : LADIM=0 257 : IF(NCOMP.EQ.4) LADIM=2 258 : IF(NCOMP.EQ.9) LADIM=3 259 : IF(LADIM.EQ.0) GO TO 9990 260 : * 261 : * BOUCLE SUR LES ELEMENTS ET LES POINTS DE GAUSS 262 : * 263 : 264 : DO 31 IB=1,N1EL 265 : DO 31 IGAU=1,N1PTEL 266 : * 267 : * ... Recherche des composantes du gradient 268 : * 269 : MPTVAL=IVACOM 270 : DO 35 ICOMP=1,NCOMP 271 : MELVAL=IVAL(ICOMP) 272 : IGMN=MIN(IGAU,VELCHE(/1)) 273 : IBMN=MIN(IB ,VELCHE(/2)) 274 : F(ICOMP)=VELCHE(IGMN,IBMN) 275 : 35 CONTINUE 276 : * 277 : * on ajoute 1. si on a lu le mot DEPL 278 : * 279 : IF(IMIL.EQ.1) THEN 280 : IF(LADIM.EQ.2) THEN 281 : F(1)=F(1)+1.D0 282 : F(4)=F(4)+1.D0 283 : ELSE IF(LADIM.EQ.3) THEN 284 : F(1)=F(1)+1.D0 285 : F(5)=F(5)+1.D0 286 : F(9)=F(9)+1.D0 287 : ENDIF 288 : ENDIF 289 : * 290 : * ... Calcul de R et U 291 : * 291 : CALL POLA2(F,R,U,LADIM) 292 : IF(IERR.NE.0) GO TO 9990 293 : * 294 : * ... et leur stockage ... 295 : * 296 : MPTVAL=IVAGR1 297 : DO 36 ICOMP=1,NCOMP 298 : MELVAL=IVAL(ICOMP) 299 : VELCHE(IGAU,IB)=R(ICOMP) 300 : 36 CONTINUE 301 : 302 : MPTVAL=IVAGR2 303 : DO 37 ICOMP=1,NCOMP 304 : MELVAL=IVAL(ICOMP) 305 : VELCHE(IGAU,IB)=U(ICOMP) 306 : 37 CONTINUE 307 : * 308 : 31 CONTINUE 309 : * 310 : * 311 : * ... DESACTIVATION DES SEGMENTS PROPRES A LA GEOMETRIE ISOUS ... 312 : * 313 : MPTVAL=IVAGR1 314 : DO 76 ICOMP=1,NCOMP 315 : MELVAL=IVAL(ICOMP) 316 : SEGDES MELVAL 317 : 76 CONTINUE 318 : 319 : MPTVAL=IVAGR2 320 : DO 77 ICOMP=1,NCOMP 321 : MELVAL=IVAL(ICOMP) 322 : SEGDES MELVAL 323 : 77 CONTINUE 324 : * 325 : * 326 : SEGDES MCHAM1,MCHAM2 327 : * 327 : CALL DTMVAL(IVACOM,1) 328 : * 329 : NOMID=MOCOMP 330 : if(lsupgd)SEGSUP NOMID 331 : * SEGSUP INFO 332 : * 333 : SEGDES IMODEL 334 : * 335 : 200 CONTINUE 336 : 337 : C ... FIN DE LA GRANDE BOUCLE SUR LES ZONES ÉLÉMENTAIRES ... 338 : 339 : 340 : SEGDES MCHEL1,MCHEL2 341 : SEGDES MCHELM,MMODEL 342 : RETURN 343 : * 344 : 9990 CONTINUE 345 : * 346 : * ... ERREUR DANS UNE SOUS ZONE : DESACTIVATION ET RETOUR ... 347 : * 348 : SEGDES IMODEL,MMODEL 349 : SEGSUP MCHEL1,MCHEL2 350 : * 351 : 351 : CALL DTMVAL(IVACOM,1) 352 : * 353 : IF (IVAGR1.NE.0) THEN 354 : MPTVAL=IVAGR1 355 : DO 86 ICOMP=1,NCOMP 356 : MELVAL=IVAL(ICOMP) 357 : SEGSUP MELVAL 358 : 86 CONTINUE 359 : ENDIF 360 : * 361 : IF (IVAGR2.NE.0) THEN 362 : MPTVAL=IVAGR2 363 : DO 87 ICOMP=1,NCOMP 364 : MELVAL=IVAL(ICOMP) 365 : SEGSUP MELVAL 366 : 87 CONTINUE 367 : ENDIF 368 : * 369 : NOMID =MOCOMP 370 : if(lsupgd)SEGSUP NOMID 371 : * 372 : * SEGSUP INFO 373 : RETURN 374 : * 375 : 666 CONTINUE 376 : SEGDES MCHELM 377 : RETURN 378 : END 379 : 380 : 381 : 382 : 383 : 384 : 385 : 386 : 387 : 388 : 389 : 390 : 391 :
© Cast3M 2003 - All rights reserved.
Disclaimer