epsln1
C EPSLN1 SOURCE CB215821 24/04/12 21:15:48 11897 *--------------------------------------------------------------------- * * CALCUL DE LA DEFORMATION LOGARITHMIQUE * (APPELE PAR EPSI) * * ENTREES: * -------- * * IPMODL POINTEUR SUR UN MMODEL * IPCHGR POINTEUR SUR UN MCHAML DE GRADIENTS * IPCHCA POINTEUR SUR UN MCHAML DE CARACTERISTIQUES * --> NON UTILISE POUR LE MOMENT * IMIL ENTIER CORRESPONDANT A GEOM (=0) OU A DEPL (=1) * SI LE GRADIENT IPCHE1 EST CELUI DE LA TRANSFORMATION * OU D'UN DEPLACEMENT. * * SORTIES : * --------- * * IPCHDE POINTEUR SUR UN MCHAML DE DEFORMATIONS * = 0 EN CAS D'ERREUR * *--------------------------------------------------------------------- * IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC CCHAMP -INC SMCHAML -INC SMMODEL -INC SMINTE * SEGMENT NOTYPE CHARACTER*16 TYPE(NBTYPE) ENDSEGMENT * SEGMENT MPTVAL INTEGER IPOS(NS) ,NSOF(NS) INTEGER IVAL(NCOSOU) CHARACTER*16 TYVAL(NCOSOU) ENDSEGMENT * * Support des MCHAML (si non exprimes aux noeuds) PARAMETER (INTYPS = 5) * PARAMETER ( NINF=3 ) INTEGER INFOS(NINF) CHARACTER*(NCONCH) CONM logical lsupde,lsupgr * DIMENSION F(9), EPS(6) * IPCHDE = 0 IPCHS3 = 0 * * Reduction des MCHAMLs sur le modele IPMODL * kerre = 0 * IPCHE1 = IPCHGR IF (IERR.NE.0) RETURN IPCHE1 = ipch * IPCHE2 = IPCHCA IF (IPCHE2.NE.0) THEN IF (IERR.NE.0) RETURN IPCHE2 = ipch ENDIF * * Verification sur le type de IPCHE1 (GRADIENT) * MCHELM = IPCHE1 SEGACT,MCHELM IF (TITCHE.NE.'GRADIENT') THEN MOTERR(1:8)='GRADIENT' GOTO 9990 ENDIF * * VERIFICATION DU LIEU SUPPORT DES MCHAMLS D'ENTREE * IF (ISUP1.GT.1) GOTO 9990 IF (IPCHE2.NE.0) THEN IF (ISUP2.GT.1) GOTO 9990 ENDIF * * ACTIVATION DU MODELE * MMODEL=IPMODL SEGACT,MMODEL NSOUS = KMODEL(/1) * C ... Initialisation du MCHELM de DEFORMATIONS resultat ... * * DETERMINATION DU NOMBRE DE SOUS-ZONES DU MCHAML * N1 = 0 DO ISOUS = 1, NSOUS IMODEL = KMODEL(ISOUS) SEGACT,IMODEL MELE = NEFMOD IF (MELE.NE.22.AND.FORMOD(1).NE.'CHARGEMENT') N1 = N1 + 1 IF (MELE.NE.259.AND.FORMOD(1).NE.'CHARGEMENT') N1 = N1 + 1 ENDDO C L1 = 12 N3 = 6 SEGINI,MCHEL1 IPCHS3 = MCHEL1 C C le MCHAML resultat est de type DEFORMATIONS C MCHEL1.IFOCHE=IFOUR MCHEL1.TITCHE='DEFORMATIONS' * * Petit segment utile (defini une fois pour toutes) * NBTYPE = 1 SEGINI,NOTYPE TYPE(1)='REAL*8' MOTYPG = NOTYPE * =================================== * ... BOUCLE SUR LES SOUS ZONES DU MODELE ... * =================================== ISOUSS = 0 * DO 10 ISOUS = 1, NSOUS * * ... INITIALISATIONS ... * NGRA =0 IVAGRA=0 MOGRAD=0 lsupgr = .false. NDEF=0 IVAEPS=0 MOEPSI=0 lsupde = .false. IPMINT = 0 * * ... TRAITEMENT DU SOUS-MODELE ... * IMODEL=KMODEL(ISOUS) c* SEGACT,IMODEL * MELE = NEFMOD IPMAIL= IMAMOD CONM = CONMOD IF (MELE.EQ.22.OR.FORMOD(1).EQ.'CHARGEMENT') GOTO 199 IF (MELE.EQ.259.OR.FORMOD(1).EQ.'CHARGEMENT') GOTO 199 * ISOUSS = ISOUSS + 1 * * ... INFOS GENERALES ... * C ... COQUE INTEGREE OU PAS ? ... C IF (INFMOD(/1).NE.0) THEN NPINT=INFMOD(1) ELSE NPINT=0 ENDIF IF (NPINT.NE.0) THEN GOTO 199 ENDIF * * ... INFORMATION SUR L'ELEMENT FINI ... * MFR =INFELE(13) * IPMINT =INFELE(11) IPMINT=INFMOD(2+INTYPS) IF (IPMINT.NE.0) THEN MINTE = IPMINT SEGACT,MINTE ENDIF IPPORE = 0 * * TEST SUR MFR : MASSIF UNIQUEMENT POUR L'INSTANT * IF (MFR.NE.1) THEN GOTO 199 ENDIF * * ... Verification de compatibilité des MCHAML du point de vue des * tableaux INFCHE et remplissage du tableau INFOS pour KOMCHA ... * IF (iret.EQ.0) GOTO 199 * * ... RECHERCHE DES NOMS de COMPOSANTES ... * IF (lnomid(3).NE.0) THEN mograd = lnomid(3) ELSE lsupgr = .true. ENDIF nomid=MOGRAD SEGACT,nomid NGRA=lesobl(/2) C* nfac=lesfac(/2) * LADIM=0 IF (NGRA.EQ.4) LADIM=2 IF (NGRA.EQ.9) LADIM=3 IF (LADIM.EQ.0) THEN GOTO 199 ENDIF IF (lnomid(5).NE.0) THEN MOEPSI = lnomid(5) ELSE lsupde = .true. ENDIF nomid=MOEPSI SEGACT,nomid NDEF = lesobl(/2) C* nfac=lesfac(/2) * * ... VERIFICATION DE LEUR PRESENCE ... * IF (IERR.NE.0) GOTO 199 * * Changement de support du gradient (NOEUDS vers INTYPS) IF (ISUP1.EQ.1) THEN IF (IERR.NE.0) THEN ISUP1 = 0 GOTO 199 ENDIF ENDIF * * ... RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER ... * N1PTEL=0 N1EL =0 MPTVAL=IVAGRA DO 110 ICOMP=1,NGRA MELVAL=IVAL(ICOMP) N1PTEL=MAX(N1PTEL,VELCHE(/1)) N1EL =MAX(N1EL ,VELCHE(/2)) 110 CONTINUE N2PTEL=0 N2EL=0 * * ... Les attributs de chaque sous-zone ... * MCHEL1.INFCHE(ISOUSS,1)=0 MCHEL1.INFCHE(ISOUSS,2)=0 MCHEL1.INFCHE(ISOUSS,3)=NIFOUR MCHEL1.INFCHE(ISOUSS,4)=IPMINT MCHEL1.INFCHE(ISOUSS,5)=0 MCHEL1.INFCHE(ISOUSS,6)=INTYPS MCHEL1.IMACHE(ISOUSS)=IPMAIL MCHEL1.CONCHE(ISOUSS)=CONMOD * * ... Création et stockage des MCHAML ... * N2 = NDEF SEGINI,MCHAM1 MCHEL1.ICHAML(ISOUSS)=MCHAM1 * C ... et des MELVAL de la zone élémentaire ... C NS=1 NCOSOU=NDEF SEGINI,MPTVAL IVAEPS=MPTVAL NOMID=MOEPSI DO 111 ICOMP=1,NDEF MCHAM1.TYPCHE(ICOMP)='REAL*8' MCHAM1.NOMCHE(ICOMP)=LESOBL(ICOMP) SEGINI,MELVAL MCHAM1.IELVAL(ICOMP)=MELVAL IVAL(ICOMP)=MELVAL 111 CONTINUE * ********************************************************************** * * * BRANCHEMENT SUIVANT LA DIMENSION * * * ********************************************************************** * * BOUCLE SUR LES ELEMENTS ET LES POINTS DE GAUSS * DO 31 IB=1,N1EL * DO 31 IGAU=1,N1PTEL * * ... Recherche des composantes du gradient * MPTVAL=IVAGRA DO 35 ICOMP = 1, NGRA MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) F(ICOMP)=VELCHE(IGMN,IBMN) 35 CONTINUE * * ... Ajout de 1 aux termes diagonaux si mot DEPL lu * IF (IMIL.EQ.1) THEN IF (LADIM.EQ.3) THEN F(1)=F(1)+1. F(5)=F(5)+1. F(9)=F(9)+1. ELSE IF (LADIM.EQ.2) THEN F(1)=F(1)+1. F(4)=F(4)+1. ENDIF ENDIF * * ... Calcul des composantes de EPS ... * IF (IERR.NE.0) GOTO 199 * * ... et leur stockage ... * MPTVAL=IVAEPS DO 36 ICOMP=1,NDEF MELVAL=IVAL(ICOMP) VELCHE(IGAU,IB)=EPS(ICOMP) 36 CONTINUE * 31 CONTINUE * * ... DESACTIVATION DES SEGMENTS PROPRES A LA GEOMETRIE ISOUS ... * 199 CONTINUE * IF (IPMINT.NE.0) THEN MINTE = IPMINT SEGDES,MINTE ENDIF * IF (ISUP1.EQ.1) THEN ELSE ENDIF * IF (IERR.EQ.0) THEN MPTVAL=IVAEPS DO ICOMP = 1, IVAL(/1) MELVAL = IVAL(ICOMP) IVAL(ICOMP)=MELVAL ENDDO SEGDES,MCHAM1 ELSE SEGSUP,MCHAM1 ENDIF * IF (MOGRAD.NE.0) THEN nomid=MOGRAD SEGDES,nomid IF (lsupgr) SEGSUP,nomid ENDIF * IF (MOEPSI.NE.0) THEN nomid=MOEPSI SEGDES,nomid IF (lsupde) SEGSUP,nomid ENDIF * SEGDES,IMODEL * IF (IERR.NE.0) GOTO 9991 * 10 CONTINUE C =========================================== C ... FIN DE LA BOUCLE SUR LES ZONES ELEMENTAIRES ... C =========================================== * 9991 CONTINUE SEGDES,MMODEL notype = MOTYPG SEGSUP,notype IF (IERR.NE.0) THEN SEGSUP,MCHEL1 IPCHDE = 0 ELSE SEGDES,MCHEL1 IPCHDE = IPCHS3 ENDIF 9990 CONTINUE SEGDES,MCHELM RETURN END
© Cast3M 2003 - Tous droits réservés.
Mentions légales