1 : C NLOCA1 SOURCE CHAT 11/03/16 21:28:35 6902 2 : SUBROUTINE NLOCA1(IPCHI,IPLMOT,IPCHCO, IPCHO, IRET) 3 : C_______________________________________________________________________ 4 : C 5 : C CALCUL DE LA MOYENNE NONLOCALE 6 : C 7 : C 8 : C Entrees: 9 : C ________ 10 : C 11 : C IPCHI Pointeur sur un MCHAML de ss-type indifferent 12 : C IPLMOT Pointeur sur un LISTMOTS de noms de composante 13 : C 14 : C IPCHCO Pointeur sur un MCHAML de Connectivite 15 : C (ss-type CONNECTIVITE NON LOCAL) 16 : C 17 : C Sorties: 18 : C ________ 19 : C 20 : C IPCHO Pointeur sur un MCHAML de meme ss-type que IPCHI 21 : C avec les composantes IPLMOT moyennees 22 : C les composantes non reconnues dans iplmot sont 23 : C recopiees 24 : C 25 : C IRET 1 ou 0 suivant succes ou pas 26 : C 27 : C 28 : C Appele par: NLOCAL 29 : C ----------- 30 : C 31 : C Appel a: 32 : C -------- 33 : C 34 : C NLOVEP verification et preparation de la moyenne 35 : C TRTRVE point translate 36 : C TRSYPT point symetrique par rapport a un point 37 : C TRSYDR point symetrique par rapport a une droite 38 : C TRSYPL point symetrique par rapport a un plan 39 : C DOXE, JACOBI 40 : C 41 : C P.PEGON OCTOBRE 92 D'APRES C. LA BORDERIE AVRIL 1992 D'APRES P. PEGON 42 : C_______________________________________________________________________ 43 : C 44 : IMPLICIT INTEGER(I-N) 45 : IMPLICIT REAL*8(A-H,O-Z) 46 : * 47 : -INC SMMODEL 48 : -INC CCOPTIO 49 : -INC SMELEME 50 : -INC SMCOORD 51 : -INC SMCHAML 52 : -INC SMLENTI 53 : -INC SMLREEL 54 : -INC SMLMOTS 55 : -INC SMINTE 56 : ** 57 : * SEGMENT INFO 58 : * INTEGER INFELE(JG) 59 : * ENDSEGMENT 60 : * 61 : SEGMENT,WRK1 62 : REAL*8 XE(3,NBNN) 63 : ENDSEGMENT 64 : * 65 : SEGMENT NLOC1 66 : INTEGER ILOC2 (NZONEF) 67 : END SEGMENT 68 : * 69 : SEGMENT NLOC2 70 : INTEGER MPCHAM (NDOUBL) 71 : INTEGER ILOC4 (NDOUBL) 72 : INTEGER MODLAC,MAILEF,MINTEF 73 : INTEGER MAILAC (NSZACC) 74 : INTEGER MINTAC (NSZACC) 75 : INTEGER ILOC3 (NSZACC) 76 : INTEGER ILOC3I,ILOC3O 77 : INTEGER MELCAR 78 : END SEGMENT 79 : * 80 : SEGMENT NLOC3 81 : INTEGER MELVAC (NCOMP) 82 : END SEGMENT 83 : * 84 : SEGMENT NLOC4 85 : INTEGER JCLE 86 : REAL*8 PT1(3),PT2(3),DISP 87 : INTEGER MELPNI,MELPLI 88 : END SEGMENT 89 : * 90 : SEGMENT,WRK2 91 : REAL*8 XEJ(3,NBNJ),SHP(6,NBNJ) 92 : ENDSEGMENT 93 : * 94 : SEGMENT WRK3 95 : REAL*8 SOMCOM(NCOMP,NBPGAU) 96 : REAL*8 SOMJAC( NBPGAU) 97 : END SEGMENT 98 : * 99 : POINTEUR MLCOMP.MLENTI 100 : POINTEUR MLNIMO.MLENTI 101 : * 102 : C 103 : DIMENSION XXX(3),XXXJ(3) 104 : C+PP 105 : DATA XMULTL/1.5/ 106 : C+PP 107 : NHRM=NIFOUR 108 : IRET=1 109 : C 110 : C ON VERIFIE/PREPARE LES DONNEES 111 : C 111 : CALL NLOVEP(IPCHCO,IPCHI,IPLMOT, IPCHO,NLOC1, IRET) 112 : IF (IRET.EQ.0)RETURN 113 : C 114 : C ON TRAITE L'INFORMATION 115 : C 116 : C BOUCLE SUR LES ZONES EFFECTIVES 117 : C 118 : NZONEF=ILOC2(/1) 119 : DO ISOUCF=1,NZONEF 120 : C write(IOIMP,*)'ZONE EFFECTIVE',ISOUCF 121 : NLOC2=ILOC2(ISOUCF) 122 : MINTE1=MINTEF 123 : IPT1=MAILEF 124 : NDOUBL=ILOC4(/1) 125 : NLOC3=ILOC3I 126 : NCOMP=MELVAC(/1) 127 : C 128 : C NOMBRE DE POINTS DE GAUSS PAR ELEMENTS POUR LA SS ZONE A MOYENNER 129 : C 130 : NBPGAU=MINTE1.POIGAU(/1) 131 : C 132 : C NOMBRE D'ELEMENTS ET DE NOEUDS POUR LA SS ZONE A MOYENNER 133 : C 134 : NBELEM=IPT1.NUM(/2) 135 : NBNN =IPT1.NUM(/1) 136 : SEGINI WRK1 137 : SEGINI WRK3 138 : C 139 : C DEBUT DE LA BOUCLE SUR LES ELEMENTS 140 : C 141 : DO IB=1,NBELEM 142 : C write(IOIMP,*)' ELEMENT NUMERO',IB 143 : C 144 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 145 : C 145 : CALL DOXE(XCOOR,IDIM,NBNN,IPT1.NUM,IB,XE) 146 : C 147 : C INITIALISATION DES DIVERSES INTEGRATIONS 148 : C 149 : DO IGAU=1,NBPGAU 150 : SOMJAC(IGAU)=0.D0 151 : DO IE1=1,NCOMP 152 : SOMCOM(IE1,IGAU)=0.D0 153 : END DO 154 : END DO 155 : C 156 : C ON BOUCLE SUR LES DOUBLONS 157 : C 158 : DO IDOUBL=1,NDOUBL 159 : NLOC4=ILOC4(IDOUBL) 160 : ICLE=JCLE 161 : C 162 : C ON RECUPERE LE NUMERO D'ORDRE DES SOUS ZONES ACCESSIBLES 163 : C 164 : MELVAL=MELPNI 165 : MLNIMO=IELCHE(1,IB) 166 : C write(IOIMP,*)' DOUBLON ICLE MLNIMO ',IDOUBL,ICLE,MLNIMO 167 : C 168 : C CET ELEMENT EST IL EN CONNECTIVITE ? 169 : C 170 : IF (MLNIMO.NE.0)THEN 171 : SEGACT,MLNIMO 172 : C 173 : C ON RECUPERE LA LISTE DES ELEMENTS ACCESSIBLES DANS 174 : C LE CHAMELEM DE CONNECTIVITE 175 : C 176 : MELVAL=MELPLI 177 : MLENTI=IELCHE(1,IB) 178 : SEGACT,MLENTI 179 : C 180 : C ON CREE UN MLENT1 QUI PERMETTRA DE TROUVER LE DEBUT DE L'INFORMATION 181 : C CONCERNANT CHAQUE SS ZONE 182 : C 183 : JG=1 184 : SEGINI MLENT1 185 : MLENT1.LECT(1)=1 186 : NSOUSA=MLNIMO.LECT(/1) 187 : IF (NSOUSA.GT.1)THEN 188 : DO IISOUJ=2,NSOUSA 189 : JG=MLENT1.LECT(/1)+1 190 : SEGADJ MLENT1 191 : MLENT1.LECT(JG)=MLENT1.LECT(JG-1)+ 192 : 1 LECT(MLENT1.LECT(JG-1))+1 193 : END DO 194 : ENDIF 195 : C 196 : C DEBUT DE LA BOUCLE SUR LES PTS D'INTEGRATION 197 : C 198 : DO IGAU=1,NBPGAU 199 : C 200 : C ON RECUPERE LA LONGUEUR CARACTERISTIQUE 201 : C 202 : MELVAL=MELCAR 203 : XLONG=VELCHE(MIN(IGAU,VELCHE(/1)),MIN(IB,VELCHE(/2))) 204 : C write(IOIMP,*)' GAUSS-P,XLONG ',IGAU,XLONG 205 : C 206 : C ON CHERCHE LA POSITION ABSOLUE DU POINT D"INTEGRATION 207 : C 208 : DO IE1=1,3 209 : XXX(IE1)=0.D0 210 : DO IE2=1,NBNN 211 : CGAUSS=MINTE1.SHPTOT(1,IE2,IGAU) 212 : XXX(IE1)=XXX(IE1)+XE(IE1,IE2)*CGAUSS 213 : END DO 214 : END DO 215 : C write(IOIMP,*)' XXX ',XXX 216 : C 217 : C DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES ACCESSIBLES 218 : C 219 : DO IISOUJ=1,NSOUSA 220 : IISOUS=MLNIMO.LECT(IISOUJ) 221 : NLOC3=ILOC3(IISOUS) 222 : IPT2=MAILAC(IISOUS) 223 : MINTE2=MINTAC(IISOUS) 224 : C 225 : NBPGAJ=MINTE2.POIGAU(/1) 226 : NBNJ =IPT2.NUM(/1) 227 : C 228 : IG1=MLENT1.LECT(IISOUJ) 229 : NBELEJ=LECT(IG1) 230 : C write(IOIMP,*)' ZONES-AC,IISOUS ',IISOUJ,IISOUS 231 : C 232 : C DEBUT DE LA BOUCLE SUR LES ELEMENTS ACCESSIBLES 233 : C 234 : SEGINI,WRK2 235 : DO IIBJ=1,NBELEJ 236 : IG1=IG1+1 237 : IBJ=LECT(IG1) 238 : C write(IOIMP,*)' ELEMENT_AC ',IBJ 239 : C 240 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IIBJ 241 : C 241 : CALL DOXE(XCOOR,IDIM,NBNJ,IPT2.NUM,IBJ,XEJ) 242 : C 243 : C DEBUT DE LA BOUCLE SUR LES PTS D'INTEGRATION 244 : C 245 : DO IGAUJ=1,NBPGAJ 246 : C 247 : C ON CHERCHE LA POSITION ABSOLUE DU POINT D"INTEGRATION 248 : C 249 : DO IE1=1,3 250 : XXXJ(IE1)=0.D0 251 : DO IE2=1,NBNJ 252 : CGAUSS=MINTE2.SHPTOT(1,IE2,IGAUJ) 253 : XXXJ(IE1)=XXXJ(IE1)+XEJ(IE1,IE2)*CGAUSS 254 : END DO 255 : END DO 256 : C write(IOIMP,*)' GAUSS-AC ',IGAUJ 257 : C write(IOIMP,*)' XXXJ-AS ',XXXJ 258 : C 259 : C ON TRANSFORME CES COORDONNEES EN FONCTION DES SYMETRIE OU DE LA 260 : C TRANSLATION 261 : C 261 : IF(ICLE.EQ.2)CALL TRTRVE(XXXJ,1,PT1 ) 261 : IF(ICLE.EQ.3)CALL TRSYPT(XXXJ,1,PT1 ) 261 : IF(ICLE.EQ.4)CALL TRSYDR(XXXJ,1,PT1,PT2 ) 261 : IF(ICLE.EQ.5)CALL TRSYPL(XXXJ,1,PT1,DISP) 262 : C write(IOIMP,*)' XXXJ-PS ',XXXJ 263 : C 264 : C ON REMPLIT LES SHP 265 : C 266 : DO IE1=1,6 267 : DO IE2=1,NBNJ 268 : SHP(IE1,IE2)=MINTE2.SHPTOT(IE1,IE2,IGAUJ) 269 : END DO 270 : END DO 271 : C 272 : C ON CALCULE LE JACOBIEN 273 : C 273 : CALL JACOBI(XEJ,SHP,IDIM,NBNJ,DJAC) 274 : C 275 : C ON CALCULE LA VALEUR DE LA GAUSSIENNE 276 : C 277 : XXLONG=(XXX(1)-XXXJ(1))**2+(XXX(2)-XXXJ(2))**2+ 278 : 1 (XXX(3)-XXXJ(3))**2 279 : XXLONG=SQRT(XXLONG) 280 : C write(IOIMP,*)' XXLONG,DJAC ',XXLONG,DJAC 281 : IF(XXLONG.LE.XMULTL*XLONG)THEN 282 : GDEX=EXP(-(2*XXLONG/XLONG)**2) 283 : DJAC=MINTE2.POIGAU(IGAUJ)*GDEX*ABS(DJAC) 284 : DO IE1=1,NCOMP 285 : MELVAL=MELVAC(IE1) 286 : C 287 : C ON DOIT RETROUVER LE NUMERO D'ELEMENT ATTACHE AU CHAMELEM 288 : C CORRESPONDANT A CELUI DU MELEME 289 : C 290 : IBMN=MIN(IBJ ,VELCHE(/2)) 291 : IGMN=MIN(IGAUJ,VELCHE(/1)) 292 : SOMCOM(IE1,IGAU)=SOMCOM(IE1,IGAU) 293 : 1 +VELCHE(IGMN,IBMN)*DJAC 294 : C write(IOIMP,*)' VELCHE,DJAC ',VELCHE(IGMN,IBMN),DJAC 295 : END DO 296 : SOMJAC(IGAU)=SOMJAC(IGAU)+DJAC 297 : ENDIF 298 : C 299 : C FIN DE LA BOUCLE SUR LES PTS D'INTEGRATION 300 : C 301 : END DO 302 : C 303 : C FIN DE LA BOUCLE SUR LES ELEMENTS ACCESSIBLES 304 : C 305 : END DO 306 : C 307 : SEGSUP,WRK2 308 : C 309 : C FIN DE LA BOUCLE SUR LES DIFFERENTES ZONES ACCESSIBLES 310 : C 311 : END DO 312 : C 313 : C FIN DE LA BOUCLE SUR LES PTS D'INTEGRATION 314 : C 315 : END DO 316 : SEGDES MLENTI 317 : SEGDES MLNIMO 318 : SEGSUP MLENT1 319 : C 320 : C FIN DU TEST D'EXISTENCE DE CONNECTIVITE SUR L'ELEMENT 321 : C 322 : ENDIF 323 : C 324 : C FIN DE LA BOUCLE SUR LES DOUBLONS 325 : C 326 : END DO 327 : C 328 : NLOC3=ILOC3O 329 : DO IGAU=1,NBPGAU 330 : DO IE1=1,NCOMP 331 : MELVAL=MELVAC(IE1) 332 : SEGACT MELVAL*MOD 333 : VELCHE(IGAU,IB)=SOMCOM(IE1,IGAU)/SOMJAC(IGAU) 334 : END DO 335 : END DO 336 : C 337 : C FIN DE LA BOUCLE SUR LES ELEMENTS 338 : C 339 : END DO 340 : SEGSUP WRK1 341 : SEGSUP WRK3 342 : C 343 : C FIN DE LA BOUCLE SUR LES SOUS ZONES EFFECTIVES 344 : C 345 : END DO 346 : C 347 : C DESACTIVATIONS/SUPRESSION 348 : C WARNING SUR LES DOUBLONS DE MODEL! 349 : C 350 : DO IZONEF=1,NZONEF 351 : NLOC2=ILOC2(IZONEF) 352 : NDOUBL=ILOC4(/1) 353 : DO IDOUBL=1,NDOUBL 354 : NLOC4=ILOC4(IDOUBL) 355 : MELVAL=MELPNI 356 : SEGDES,MELVAL 357 : MELVAL=MELPLI 358 : SEGDES,MELVAL 359 : SEGSUP,NLOC4 360 : ENDDO 361 : NSZACC=ILOC3(/1) 362 : DO ISZACC=1,NSZACC 363 : NLOC3=ILOC3(ISZACC) 364 : SEGSUP,NLOC3 365 : ENDDO 366 : NLOC3=ILOC3I 367 : NCOMP=MELVAC(/1) 368 : DO ICOMP=1,NCOMP 369 : MELVAL=MELVAC(ICOMP) 370 : SEGDES,MELVAL 371 : ENDDO 372 : SEGSUP,NLOC3 373 : NLOC3=ILOC3O 374 : NCOMP=MELVAC(/1) 375 : DO ICOMP=1,NCOMP 376 : MELVAL=MELVAC(ICOMP) 377 : SEGDES,MELVAL 378 : ENDDO 379 : SEGSUP,NLOC3 380 : MMODEL=MODLAC 381 : DO ISZACC=1,NSZACC 382 : MINTE=MINTAC(ISZACC) 383 : SEGDES,MINTE 384 : IMODEL=KMODEL(ISZACC) 385 : SEGDES,IMODEL 386 : ENDDO 387 : MELEME=MAILEF 388 : SEGDES,MELEME 389 : ENDDO 390 : DO IZONEF=1,NZONEF 391 : NLOC2=ILOC2(IZONEF) 392 : MMODEL=MODLAC 393 : SEGDES,MMODEL 394 : SEGSUP,NLOC2 395 : ENDDO 396 : SEGSUP,NLOC1 397 : C 398 : C BYE BYE 399 : C 400 : RETURN 401 : END 402 : 403 : 404 : 405 : 406 : 407 : 408 : 409 : 410 : 411 : 412 :
© Cast3M 2003 - All rights reserved.
Disclaimer