C FRIGTA SOURCE OF166741 25/02/21 21:16:51 12166 SUBROUTINE FRIGTA(IPMODL,IPCAR,IPVARI,CRIGI) ********************************************************************** * * COMPOSANTES DE LA RIGIDITE (HOOK) TANGENTE * CONTRIBUTION DES ELEMENTS DE CHAQUE SS_ZONE DU MODELE DE * SECTION * ********************************************************************** * * ENTREES: * * IPMODL = POINTEUR SUR UN OBJET MMODEL * IPCAR = POINTEUR SUR UN MCHAML DE CARACTERISTIQUES * IPVARI = POINTEUR SUR UN MCHAML DE VARIABLE INTERNE * * SORTIES: * * ************************************************************************ * Pierre Pegon (ISPRA) Juillet/Aout 1993 *********************************************************************** IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC CCHAMP -INC SMCHAML -INC SMELEME -INC SMCOORD -INC SMMODEL -INC SMINTE -INC TMPTVAL SEGMENT NOTYPE CHARACTER*16 TYPE(NBTYPE) ENDSEGMENT DIMENSION CRIGI(12) CHARACTER*8 CMATE CHARACTER*(NCONCH) CONM CHARACTER*16 MOMODL(10) PARAMETER ( NINF=3 ) INTEGER INFOS(NINF) LOGICAL lsupva,lsupma,lsupca lsupma=.false. lsupca=.false. lsupva=.false. C NHRM=NIFOUR C C VERIFICATION DU LIEU SUPPORT DU MCHAML DE CARACTERISTIQUES C CALL QUESUP(IPMODL,IPCAR,5,0,ISUP5,IRETCA) IF (ISUP5.GT.1) RETURN * * VERIFICATION DU LIEU SUPPORT DU MCHAML DE VARIABLES INTERNES * CALL QUESUP(IPMODL,IPVARI,5,0,ISUP5,IRETVI) 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 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 MOVARI=0 IVARI=0 IPMINT=0 C C ON RECUPERE L INFORMATION GENERALE C IMODEL=KMODEL(ISOUS) SEGACT IMODEL IPMAIL=IMAMOD CONM =CONMOD * MELE=NEFMOD MELEME=IMAMOD SEGACT MELEME NBNN=NUM(/1) NBELEM=NUM(/2) C+PPf C ON EVACUE LE CAS DU SEGS EN 3D IF(MELE.EQ.166.AND.IDIM.EQ.3)THEN CALL ERREUR(832) GOTO 9990 ENDIF C+PPf C C TRAITEMENT DU MODELE C NFOR=FORMOD(/2) NMAT=MATMOD(/2) C C NATURE DU MATERIAU C CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INFIBR) IF (CMATE.EQ.' ')THEN CALL ERREUR(251) GOTO 9990 ENDIF IF(MATE.NE.1)THEN CALL ERREUR(635) GOTO 9990 ENDIF CALL TEMANF(INFIBR,NIFIBR) IF((NIFIBR.EQ.0).AND.(INFIBR.NE.0))THEN CALL ERREUR(636) GOTO 9990 ENDIF INFIBR=NIFIBR * C____________________________________________________________________ C C INFORMATION SUR L'ELEMENT FINI C____________________________________________________________________ C MFR =INFELE(13) IPPORE=0 IF(MFR.EQ.33) IPPORE=NBNN IF (MFR.NE.47)THEN CALL ERREUR(637) GOTO 9990 ENDIF NBG =INFELE(6) NBGS =INFELE(4) LRE =INFELE(9) * MINTE=INFELE(11) MINTE=INFMOD(7) IPMINT=MINTE SEGACT,MINTE C C CREATION DU TABLEAU INFOS C CALL IDENT(IPMAIL,CONM,IPCAR,IPCAR,INFOS,IRTD) IF (IRTD.EQ.0) GOTO 9990 * * 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. CALL IDMATR(MFR,IMODEL,MOMATR,NMATR,NMATF) endif IF (MOMATR.EQ.0) THEN MOTERR(1:4)='MATE' MOTERR(5:8)=NOMTP(MELE) CALL ERREUR (76) 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 * CALL KOMCHA(IPCAR,IPMAIL,CONM,MOMATR,MOTYPE,1, & INFOS,3,IVAMAT) SEGSUP NOTYPE IF (IERR.NE.0) GOTO 9990 NMATT=NMATR+NMATF * IF (ISUP5.EQ.1) THEN CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE,MOMATR,MELE) 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. CALL IDCARB(MELE,IFOUR,MOCARA,NCARA,NCARF) endif * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' * CALL KOMCHA(IPCAR,IPMAIL,CONM,MOCARA,MOTYPE,1, & INFOS,3,IVACAR) SEGSUP NOTYPE IF (IERR.NE.0) GOTO 9990 NCARR=NCARA+NCARF * IF (ISUP5.EQ.1.AND.MOCARA.NE.0) THEN CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE,MOCARA,MELE) IF(IERR.NE.0)THEN ISUP5=0 GOTO 9990 ENDIF ENDIF * * TRAITEMENT DU CHAMP DE VARIABLES INTERNES * if(lnomid(10).ne.0) then nomid=lnomid(10) segact nomid movari=nomid nvari=lesobl(/2) nvarf=lesfac(/2) lsupva=.false. else lsupva=.true. CALL IDVARI(MFR,IMODEL,MOVARI,NVARI,NVARF) endif * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' * CALL KOMCHA(IPVARI,IPMAIL,CONM,MOVARI,MOTYPE,1,INFOS,3,IVARI) SEGSUP NOTYPE IF (IERR.NE.0) GOTO 9990 NVART=NVARI+NVARF * * APPEL AU CALCUL PROPREMENT DIT * IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN CALL FRI2T2(INFIBR,MELE,IPMAIL,IPMINT,NBGS, 1 IVAMAT,IVACAR,IVARI,NMATT,NCARR,NVART, 2 CRIGI) ELSE CALL FRIGT2(INFIBR,MELE,IPMAIL,IPMINT,NBGS, 1 IVAMAT,IVACAR,IVARI,NMATT,NCARR,NVART, 2 CRIGI) ENDIF * 9990 CONTINUE * * DESACTIVATION DES SEGMENTS * SEGDES,MELEME,IMODEL * IF (IPMINT.NE.0) SEGDES,MINTE IF(ISUP5.EQ.1)THEN CALL DTMVAL (IVAMAT,3) CALL DTMVAL (IVACAR,3) ELSE CALL DTMVAL (IVAMAT,1) CALL DTMVAL (IVACAR,1) ENDIF * IF (MOCARA.NE.0) THEN NOMID=MOCARA if(lsupca)SEGSUP NOMID END IF IF (MOVARI.NE.0) THEN NOMID=MOVARI if(lsupva)SEGSUP NOMID END IF * IF (MOMATR.NE.0) THEN NOMID=MOMATR if(lsupma)SEGSUP NOMID END IF * IF (IERR.NE.0) GO TO 888 * 1000 CONTINUE * 888 CONTINUE SEGDES MMODEL RETURN END