frigie
C FRIGIE SOURCE CB215821 24/04/12 21:16:05 11897 ********************************************************************** * * CALCUL DES COMPOSANTES DE LA RIGIDITE (HOOK) ELASTIQUE * CALCUL DES COMPOSANTES DE LA MATRICE (HOOK) DE MASSE * ... AU SIGNE PRES * CONTRIBUTION DE CHAQUE ELEMENT DE CHAQUE SS_ZONE DU MODELE * DE SECTION * ********************************************************************** * * ENTREES: * * IPMODL = POINTEUR SUR UN OBJET MMODEL * IPCAR = POINTEUR SUR UN MCHAML DE CARACTERISTIQUES * * SORTIES: * * CRIGI(12) ELEMENT DE REDUCTION DE LA RIGIDITE * CMASS(12) ELEMENT DE REDUCTION DE LA MASSE * ************************************************************************ * Pierre Pegon (ISPRA) Juillet/Aout 1993 *********************************************************************** IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) * -INC PPARAM -INC CCOPTIO -INC SMCHAML -INC SMELEME -INC SMCOORD -INC SMMODEL -INC SMINTE -INC CCHAMP C DIMENSION CRIGI(12),CMASS(12) * SEGMENT NOTYPE CHARACTER*16 TYPE(NBTYPE) ENDSEGMENT * SEGMENT MPTVAL INTEGER IPOS(NS) ,NSOF(NS) INTEGER IVAL(NCOSOU) CHARACTER*16 TYVAL(NCOSOU) ENDSEGMENT * CHARACTER*8 CMATE CHARACTER*(NCONCH) CONM CHARACTER*16 MOMODL(10) PARAMETER ( NINF=3 ) INTEGER INFOS(NINF) LOGICAL lsupma,lsupca lsupca=.false. C NHRM=NIFOUR C C VERIFICATION DU LIEU SUPPORT DU MCHAML DE CARACTERISTIQUES C IF (ISUP5.GT.1) RETURN C C ACTIVATION DU MODELE C MMODEL=IPMODL SEGACT MMODEL NSOUS=KMODEL(/1) C C MISE A ZERO DES RIGIDITES C DO IE1=1,12 CRIGI(IE1)=0.D0 CMASS(IE1)=0.D0 ENDDO C____________________________________________________________________ C C DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES C____________________________________________________________________ C DO 1000 ISOUS=1,NSOUS * * INITIALISATION * NMATF=0 NMATR=0 MOMATR=0 IVAMAT=0 NCARA=0 NCARF=0 MOCARA=0 IVACAR=0 C C ON RECUPERE L INFORMATION GENERALE C IMODEL=KMODEL(ISOUS) SEGACT IMODEL IPMAIL=IMAMOD CONM =CONMOD * MELE=NEFMOD MELEME=IMAMOD C C TRAITEMENT DU MODELE C NFOR=FORMOD(/2) NMAT=MATMOD(/2) C C NATURE DU MATERIAU C IF (CMATE.EQ.' ')THEN RETURN ENDIF IF(MATE.NE.1)THEN RETURN ENDIF IF((NIFIBR.EQ.0).AND.(INFIBR.NE.0))THEN RETURN ENDIF * SEGACT MELEME NBNN=NUM(/1) NBELEM=NUM(/2) C____________________________________________________________________ C C INFORMATION SUR L'ELEMENT FINI C____________________________________________________________________ C * CALL ELQUOI(MELE,0,5,IPINF,IMODEL) * IF (IERR.NE.0) THEN * RETURN * ENDIF * INFO=IPINF MFR =INFELE(13) IF (MFR.NE.47)THEN RETURN ENDIF NBG =INFELE(6) NBGS =INFELE(4) LRE =INFELE(9) * MINTE=INFELE(11) minte=infmod(7) IPPORE=0 IF(MFR.EQ.33) IPPORE=NBNN C C CREATION DU TABLEAU INFOS C IF (IRTD.EQ.0)THEN * INFO=IPINF * SEGSUP INFO RETURN ENDIF IPMINT=MINTE SEGACT,MINTE * * TRAITEMENT DU CHAMP DE CARACTERISTIQUES MATERIELLES * if(lnomid(6).ne.0) then nomid=lnomid(6) segact nomid momatr=nomid nmatr=lesobl(/2) nmatf=lesfac(/2) lsupma=.false. else lsupma=.true. endif IF (MOMATR.EQ.0) THEN MOTERR(1:4)='MATE' MOTERR(5:8)=NOMTP(MELE) GOTO 9990 ENDIF * IF (NIFIBR.NE.8) THEN NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' * ELSE NBTYPE=13 SEGINI NOTYPE MOTYPE=NOTYPE DO I=1,NBTYPE TYPE(I)='REAL*8' ENDDO TYPE(10)='POINTEUREVOLUTIO' TYPE(11)='POINTEUREVOLUTIO' * ENDIF * & INFOS,3,IVAMAT) SEGSUP NOTYPE IF (IERR.NE.0) GOTO 9990 NMATT=NMATR+NMATF * IF (ISUP5.EQ.1) THEN IF (IERR.NE.0) THEN ISUP5=0 GOTO 9990 ENDIF ENDIF * * TRAITEMENT DU CHAMP DE CARACTERISTIQUES GEOMETRIQUES * if(lnomid(7).ne.0) then nomid=lnomid(7) segact nomid mocara=nomid ncara=lesobl(/2) ncarf=lesfac(/2) lsupca=.false. else lsupca=.true. endif * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' * & INFOS,3,IVACAR) SEGSUP NOTYPE IF (IERR.NE.0) GOTO 9990 NCARR=NCARA+NCARF * IF (ISUP5.EQ.1.AND.MOCARA.NE.0) THEN IF (IERR.NE.0) THEN ISUP5=0 GOTO 9990 ENDIF ENDIF * * APPEL AU CALCUL PROPREMENT DIT * IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN 1 IVAMAT,IVACAR,NMATT,NCARR, 2 CRIGI,CMASS) ELSE 3 IVAMAT,IVACAR,NMATT,NCARR, 4 CRIGI,CMASS) ENDIF * 9990 CONTINUE * * DESACTIVATION DES SEGMENTS * * IF(ISUP5.EQ.1)THEN ELSE ENDIF * IF (MOCARA.NE.0) THEN NOMID=MOCARA if(lsupca)SEGSUP NOMID END IF * IF (MOMATR.NE.0) THEN NOMID=MOMATR if(lsupma)SEGSUP NOMID END IF * * IF (IPINF .NE.0) THEN * INFO=IPINF * SEGSUP INFO * END IF * IF (IERR.NE.0) GO TO 888 * 1000 CONTINUE * 888 CONTINUE * END
© Cast3M 2003 - Tous droits réservés.
Mentions légales