1 : C EPSLN1 SOURCE FANDEUR 12/03/15 21:23:51 7312 2 : 3 : SUBROUTINE EPSLN1(IPMODL,IPCHGR,IPCHCA,IPCHDE,IMIL) 4 : 5 : *--------------------------------------------------------------------- 6 : * 7 : * CALCUL DE LA DEFORMATION LOGARITHMIQUE 8 : * (APPELE PAR EPSI) 9 : * 10 : * ENTREES: 11 : * -------- 12 : * 13 : * IPMODL POINTEUR SUR UN MMODEL 14 : * IPCHGR POINTEUR SUR UN MCHAML DE GRADIENTS 15 : * IPCHCA POINTEUR SUR UN MCHAML DE CARACTERISTIQUES 16 : * --> NON UTILISE POUR LE MOMENT 17 : * IMIL ENTIER CORRESPONDANT A GEOM (=0) OU A DEPL (=1) 18 : * SI LE GRADIENT IPCHE1 EST CELUI DE LA TRANSFORMATION 19 : * OU D'UN DEPLACEMENT. 20 : * 21 : * SORTIES : 22 : * --------- 23 : * 24 : * IPCHDE POINTEUR SUR UN MCHAML DE DEFORMATIONS 25 : * = 0 EN CAS D'ERREUR 26 : * 27 : *--------------------------------------------------------------------- 28 : * 29 : IMPLICIT INTEGER(I-N) 30 : IMPLICIT REAL*8(A-H,O-Z) 31 : 32 : -INC CCOPTIO 33 : -INC CCHAMP 34 : -INC SMCHAML 35 : -INC SMMODEL 36 : -INC SMINTE 37 : * 38 : SEGMENT NOTYPE 39 : CHARACTER*16 TYPE(NBTYPE) 40 : ENDSEGMENT 41 : * 42 : SEGMENT MPTVAL 43 : INTEGER IPOS(NS) ,NSOF(NS) 44 : INTEGER IVAL(NCOSOU) 45 : CHARACTER*16 TYVAL(NCOSOU) 46 : ENDSEGMENT 47 : * 48 : * Support des MCHAML (si non exprimes aux noeuds) 49 : PARAMETER (INTYPS = 5) 50 : * 51 : PARAMETER ( NINF=3 ) 52 : INTEGER INFOS(NINF) 53 : CHARACTER*(NCONCH) CONM 54 : logical lsupde,lsupgr 55 : * 56 : DIMENSION F(9), EPS(6) 57 : * 58 : IPCHDE = 0 59 : IPCHS3 = 0 60 : * 61 : * Reduction des MCHAMLs sur le modele IPMODL 62 : * 63 : kerre = 0 64 : * 65 : IPCHE1 = IPCHGR 65 : CALL REDUAF(IPCHE1,IPMODL,ipch,0,ir,kerre) 65 : IF (ir.NE.1) CALL ERREUR(kerre) 66 : IF (IERR.NE.0) RETURN 67 : IPCHE1 = ipch 68 : * 69 : IPCHE2 = IPCHCA 70 : IF (IPCHE2.NE.0) THEN 70 : CALL REDUAF(IPCHE2,IPMODL,ipch,0,ir,kerre) 70 : IF (ir.NE.1) CALL ERREUR(kerre) 71 : IF (IERR.NE.0) RETURN 72 : IPCHE2 = ipch 73 : ENDIF 74 : * 75 : * Verification sur le type de IPCHE1 (GRADIENT) 76 : * 77 : MCHELM = IPCHE1 78 : SEGACT,MCHELM 79 : IF (TITCHE.NE.'GRADIENT') THEN 80 : MOTERR(1:8)='GRADIENT' 80 : CALL ERREUR(145) 81 : GOTO 9990 82 : ENDIF 83 : * 84 : * VERIFICATION DU LIEU SUPPORT DES MCHAMLS D'ENTREE 85 : * 85 : CALL QUESUP(IPMODL,IPCHE1,INTYPS,0,ISUP1,ir) 86 : IF (ISUP1.GT.1) GOTO 9990 87 : IF (IPCHE2.NE.0) THEN 87 : CALL QUESUP(IPMODL,IPCHE2,INTYPS,0,ISUP2,ir) 88 : IF (ISUP2.GT.1) GOTO 9990 89 : ENDIF 90 : * 91 : * ACTIVATION DU MODELE 92 : * 93 : MMODEL=IPMODL 94 : SEGACT,MMODEL 95 : NSOUS = KMODEL(/1) 96 : * 97 : C ... Initialisation du MCHELM de DEFORMATIONS resultat ... 98 : * 99 : * DETERMINATION DU NOMBRE DE SOUS-ZONES DU MCHAML 100 : * 101 : N1 = 0 102 : DO ISOUS = 1, NSOUS 103 : IMODEL = KMODEL(ISOUS) 104 : SEGACT,IMODEL 105 : MELE = NEFMOD 106 : IF (MELE.NE.22) N1 = N1 + 1 107 : ENDDO 108 : C 109 : L1 = 12 110 : N3 = 6 111 : SEGINI,MCHEL1 112 : IPCHS3 = MCHEL1 113 : C 114 : C le MCHAML resultat est de type DEFORMATIONS 115 : C 116 : MCHEL1.IFOCHE=IFOUR 117 : MCHEL1.TITCHE='DEFORMATIONS' 118 : * 119 : * Petit segment utile (defini une fois pour toutes) 120 : * 121 : NBTYPE = 1 122 : SEGINI,NOTYPE 123 : TYPE(1)='REAL*8' 124 : MOTYPG = NOTYPE 125 : 126 : * =================================== 127 : * ... BOUCLE SUR LES SOUS ZONES DU MODELE ... 128 : * =================================== 129 : ISOUSS = 0 130 : * 131 : DO 10 ISOUS = 1, NSOUS 132 : * 133 : * ... INITIALISATIONS ... 134 : * 135 : NGRA =0 136 : IVAGRA=0 137 : MOGRAD=0 138 : lsupgr = .false. 139 : NDEF=0 140 : IVAEPS=0 141 : MOEPSI=0 142 : lsupde = .false. 143 : IPMINT = 0 144 : * 145 : * ... TRAITEMENT DU SOUS-MODELE ... 146 : * 147 : IMODEL=KMODEL(ISOUS) 148 : c* SEGACT,IMODEL 149 : * 150 : MELE = NEFMOD 151 : IPMAIL= IMAMOD 152 : CONM = CONMOD 153 : IF (MELE.EQ.22) GOTO 199 154 : * 155 : ISOUSS = ISOUSS + 1 156 : * 157 : * ... INFOS GENERALES ... 158 : * 159 : C ... COQUE INTEGREE OU PAS ? ... 160 : C 161 : IF (INFMOD(/1).NE.0) THEN 162 : NPINT=INFMOD(1) 163 : ELSE 164 : NPINT=0 165 : ENDIF 166 : IF (NPINT.NE.0) THEN 166 : CALL ERREUR(615) 167 : GOTO 199 168 : ENDIF 169 : * 170 : * ... INFORMATION SUR L'ELEMENT FINI ... 171 : * 172 : MFR =INFELE(13) 173 : * IPMINT =INFELE(11) 174 : IPMINT=INFMOD(2+INTYPS) 175 : IF (IPMINT.NE.0) THEN 176 : MINTE = IPMINT 177 : SEGACT,MINTE 178 : ENDIF 179 : IPPORE = 0 180 : * 181 : * TEST SUR MFR : MASSIF UNIQUEMENT POUR L'INSTANT 182 : * 183 : IF (MFR.NE.1) THEN 183 : CALL ERREUR(26) 184 : GOTO 199 185 : ENDIF 186 : * 187 : * ... Verification de compatibilité des MCHAML du point de vue des 188 : * tableaux INFCHE et remplissage du tableau INFOS pour KOMCHA ... 189 : * 189 : CALL IDENT(IPMAIL,CONM,IPCHE1,0,INFOS,iret) 190 : IF (iret.EQ.0) GOTO 199 191 : * 192 : * ... RECHERCHE DES NOMS de COMPOSANTES ... 193 : * 194 : IF (lnomid(3).NE.0) THEN 195 : mograd = lnomid(3) 196 : ELSE 197 : lsupgr = .true. 197 : CALL IDGRAD(MFR,IFOUR,MOGRAD,NGRA,nfac) 198 : ENDIF 199 : nomid=MOGRAD 200 : SEGACT,nomid 201 : NGRA=lesobl(/2) 202 : C* nfac=lesfac(/2) 203 : * 204 : LADIM=0 205 : IF (NGRA.EQ.4) LADIM=2 206 : IF (NGRA.EQ.9) LADIM=3 207 : IF (LADIM.EQ.0) THEN 207 : CALL ERREUR(26) 208 : GOTO 199 209 : ENDIF 210 : 211 : IF (lnomid(5).NE.0) THEN 212 : MOEPSI = lnomid(5) 213 : ELSE 214 : lsupde = .true. 214 : CALL IDDEFO(IMODEL,IFOUR,MOEPSI,NDEF,nfac) 215 : ENDIF 216 : nomid=MOEPSI 217 : SEGACT,nomid 218 : NDEF = lesobl(/2) 219 : C* nfac=lesfac(/2) 220 : * 221 : * ... VERIFICATION DE LEUR PRESENCE ... 222 : * 222 : CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOGRAD,MOTYPG,1,INFOS,3,IVAGRA) 223 : IF (IERR.NE.0) GOTO 199 224 : * 225 : * Changement de support du gradient (NOEUDS vers INTYPS) 226 : IF (ISUP1.EQ.1) THEN 226 : CALL VALCHE(IVAGRA,NGRA,IPMINT,IPPORE) 227 : IF (IERR.NE.0) THEN 228 : ISUP1 = 0 229 : GOTO 199 230 : ENDIF 231 : ENDIF 232 : * 233 : * ... RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER ... 234 : * 235 : N1PTEL=0 236 : N1EL =0 237 : MPTVAL=IVAGRA 238 : DO 110 ICOMP=1,NGRA 239 : MELVAL=IVAL(ICOMP) 240 : N1PTEL=MAX(N1PTEL,VELCHE(/1)) 241 : N1EL =MAX(N1EL ,VELCHE(/2)) 242 : 110 CONTINUE 243 : N2PTEL=0 244 : N2EL=0 245 : * 246 : * ... Les attributs de chaque sous-zone ... 247 : * 248 : MCHEL1.INFCHE(ISOUSS,1)=0 249 : MCHEL1.INFCHE(ISOUSS,2)=0 250 : MCHEL1.INFCHE(ISOUSS,3)=NIFOUR 251 : MCHEL1.INFCHE(ISOUSS,4)=IPMINT 252 : MCHEL1.INFCHE(ISOUSS,5)=0 253 : MCHEL1.INFCHE(ISOUSS,6)=INTYPS 254 : MCHEL1.IMACHE(ISOUSS)=IPMAIL 255 : MCHEL1.CONCHE(ISOUSS)=CONMOD 256 : * 257 : * ... Création et stockage des MCHAML ... 258 : * 259 : N2 = NDEF 260 : SEGINI,MCHAM1 261 : MCHEL1.ICHAML(ISOUSS)=MCHAM1 262 : * 263 : C ... et des MELVAL de la zone élémentaire ... 264 : C 265 : NS=1 266 : NCOSOU=NDEF 267 : SEGINI,MPTVAL 268 : IVAEPS=MPTVAL 269 : NOMID=MOEPSI 270 : DO 111 ICOMP=1,NDEF 271 : MCHAM1.TYPCHE(ICOMP)='REAL*8' 272 : MCHAM1.NOMCHE(ICOMP)=LESOBL(ICOMP) 273 : SEGINI,MELVAL 274 : MCHAM1.IELVAL(ICOMP)=MELVAL 275 : IVAL(ICOMP)=MELVAL 276 : 111 CONTINUE 277 : * 278 : ********************************************************************** 279 : * * 280 : * BRANCHEMENT SUIVANT LA DIMENSION * 281 : * * 282 : ********************************************************************** 283 : * 284 : * BOUCLE SUR LES ELEMENTS ET LES POINTS DE GAUSS 285 : * 286 : DO 31 IB=1,N1EL 287 : * 288 : DO 31 IGAU=1,N1PTEL 289 : * 290 : * ... Recherche des composantes du gradient 291 : * 292 : MPTVAL=IVAGRA 293 : DO 35 ICOMP = 1, NGRA 294 : MELVAL=IVAL(ICOMP) 295 : IGMN=MIN(IGAU,VELCHE(/1)) 296 : IBMN=MIN(IB ,VELCHE(/2)) 297 : F(ICOMP)=VELCHE(IGMN,IBMN) 298 : 35 CONTINUE 299 : * 300 : * ... Ajout de 1 aux termes diagonaux si mot DEPL lu 301 : * 302 : IF (IMIL.EQ.1) THEN 303 : IF (LADIM.EQ.3) THEN 304 : F(1)=F(1)+1. 305 : F(5)=F(5)+1. 306 : F(9)=F(9)+1. 307 : ELSE IF (LADIM.EQ.2) THEN 308 : F(1)=F(1)+1. 309 : F(4)=F(4)+1. 310 : ENDIF 311 : ENDIF 312 : * 313 : * ... Calcul des composantes de EPS ... 314 : * 314 : CALL EPSLN2(F,EPS,LADIM) 315 : IF (IERR.NE.0) GOTO 199 316 : * 317 : * ... et leur stockage ... 318 : * 319 : MPTVAL=IVAEPS 320 : DO 36 ICOMP=1,NDEF 321 : MELVAL=IVAL(ICOMP) 322 : VELCHE(IGAU,IB)=EPS(ICOMP) 323 : 36 CONTINUE 324 : * 325 : 31 CONTINUE 326 : * 327 : * ... DESACTIVATION DES SEGMENTS PROPRES A LA GEOMETRIE ISOUS ... 328 : * 329 : 199 CONTINUE 330 : * 331 : IF (IPMINT.NE.0) THEN 332 : MINTE = IPMINT 333 : SEGDES,MINTE 334 : ENDIF 335 : * 336 : IF (ISUP1.EQ.1) THEN 336 : CALL DTMVAL(IVAGRA,3) 337 : ELSE 337 : CALL DTMVAL(IVAGRA,1) 338 : ENDIF 339 : * 340 : IF (IERR.EQ.0) THEN 341 : MPTVAL=IVAEPS 342 : DO ICOMP = 1, IVAL(/1) 343 : MELVAL = IVAL(ICOMP) 343 : CALL COMRED(MELVAL) 344 : ENDDO 344 : CALL DTMVAL(IVAEPS,1) 345 : SEGDES,MCHAM1 346 : ELSE 346 : CALL DTMVAL(IVAEPS,3) 347 : SEGSUP,MCHAM1 348 : ENDIF 349 : * 350 : IF (MOGRAD.NE.0) THEN 351 : nomid=MOGRAD 352 : SEGDES,nomid 353 : IF (lsupgr) SEGSUP,nomid 354 : ENDIF 355 : * 356 : IF (MOEPSI.NE.0) THEN 357 : nomid=MOEPSI 358 : SEGDES,nomid 359 : IF (lsupde) SEGSUP,nomid 360 : ENDIF 361 : * 362 : SEGDES,IMODEL 363 : * 364 : IF (IERR.NE.0) GOTO 9991 365 : * 366 : 10 CONTINUE 367 : C =========================================== 368 : C ... FIN DE LA BOUCLE SUR LES ZONES ELEMENTAIRES ... 369 : C =========================================== 370 : 371 : * 372 : 9991 CONTINUE 373 : SEGDES,MMODEL 374 : notype = MOTYPG 375 : SEGSUP,notype 376 : IF (IERR.NE.0) THEN 377 : SEGSUP,MCHEL1 378 : IPCHDE = 0 379 : ELSE 380 : SEGDES,MCHEL1 381 : IPCHDE = IPCHS3 382 : ENDIF 383 : 9990 CONTINUE 384 : SEGDES,MCHELM 385 : 386 : RETURN 387 : END 388 : 389 :
© Cast3M 2003 - All rights reserved.
Disclaimer