C SORE1 SOURCE CHAT 11/03/16 21:31:39 6902 SUBROUTINE SORE1 (IPMODE,IPCHEL,IPCHE4,IPCHP1,IPRIGI) ************************************************************************ * * SORE1 ----- * _____ * FONCTION: * --------- * CREATION DE LA MATRICE DE CONDUCTIVITE N DIV(GRAD T) * POUR DES ELMENTS MASSIFS UNIQUEMENT * GESTION DES SEGMENTS ET TESTS DE COMPATIBILITE * * PARAMETRES: (E)=ENTREE (S)=SORTIE (+)=CONTENU DANS UN COMMUN * ----------- * * IPMODE (E) POINTEUR SUR LE SEGMENT MMODEL * IPCHEL (E) POINTEUR SUR LE CHAMP CARACTERISTIQUES (MATER) * IPCHE4 (E) POINTEUR SUR LE CHAMP FACTEUR DE GRAD T * IPCHP1 (E) POINTEUR SUR LE CHPOINT T * IPRIGI (S) POINTEUR SUR LE SEGMENT MRIGID * * VARIABLES: * ---------- * * NBNN NOMBRE DE NOEUDS DANS L'ELEMENT CONSIDERE * NEF NUMERO DE L'ELEMENT FINI DANS NOMTP * NBMAIL NOMBRE DE MAILLAGES ELEMENTAIRES * NBELEM NOMBRE D'ELEMENTS DANS LE MAILLAGE ELEMENTAIRE * * * AUTEUR, DATE DE CREATION: * ------------------------- * * J.M.BAZE AVRIL 97 * * LANGAGE: * -------- * * ESOPE + FORTRAN77 * ************************************************************************ IMPLICIT INTEGER(I-N) -INC CCOPTIO -INC CCHAMP -INC SMRIGID -INC SMCHAML -INC SMELEME -INC SMMODEL -INC SMCHPOI CHARACTER*4 MOTHER,MOCHAL PARAMETER ( MOTHER='T ' ) PARAMETER ( MOCHAL='Q ' ) * VERIFICATION DU LIEU SUPPORT DU CHAMELEM DE CARACTERISTIQUES * CALL QUESUP(IPMODE,IPCHEL,6,0,ISUP,IRETCA) CALL QUESUP(IPMODE,IPCHEL,3,0,ISUP,IRETCA) IF(ISUP.GT.1)RETURN * * SI LE CHAMELEM EST APPUYE AUX NOEUDS ,ON CHANGE LE SUPPORT * POUR LES POINTS DE GAUSS * IF(ISUP.EQ.1)THEN CALL CHASUP(IPMODE,IPCHEL,IPCHE1,IRET,6) IF(IRET.NE.0)THEN CALL ERREUR(IRET) RETURN ENDIF ELSE IPCHE1=IPCHEL ENDIF * * CHPOINT TYPE TEMPERATURE ---> CHAMELEM AUX NOEUDS CALL CHAME1(0,IPMODE,IPCHP1,' ',IPCHE2,1) IF (IERR.NE.0) RETURN ICHCAR = 0 * GRADIENT CALL GRAD1(IPMODE,IPCHE2,ICHCAR,IPCHE3,IRET) IF(IRET.NE.1) RETURN * VERIFICATION DES SUPPORTS * MCHELM=IPCHE1 SEGACT,MCHELM NBMAIC=IMACHE(/1) SEGDES MCHELM MMODEL=IPMODE SEGACT,MMODEL NBMAIM=KMODEL(/1) IF (NBMAIM.GT.NBMAIC) THEN * * IL MANQUE LES CARACTERISTIQUES D'UNE OU PLUSIEURS PARTIES * DU MODELE * CALL ERREUR(404) SEGDES,MMODEL*NOMOD RETURN ENDIF * NBMAIL=NBMAIM * * INITIALISATION DU CHAPEAU DE L'OBJET RIGIDITE * NRIGE=8 NRIGEL=NBMAIL SEGINI,MRIGID IPRIGI=MRIGID ICHOLE=0 IMGEO1=0 IMGEO2=0 IFORIG=IFOUR ISUPEQ=0 MTYMAT='RIGIDITE' NBGEOR=0 * DO 40 IA=1,NBMAIL IRIGEL(4,IA)=0 COERIG(IA)=1.D0 40 CONTINUE * END DO IFOI=0 * * BOUCLE SUR LES MAILLAGES ELEMENTAIRES,ZONE IMAIL * DO 50 IMAIL=1,NBMAIL * IFOI=IFOI+1 IMODEL=KMODEL(IMAIL) SEGACT,IMODEL * NEF=NEFMOD NF1=FORMOD(/2) MELEME=IMAMOD SEGACT,MELEME * NBNN=NUM(/1) NBELEM=NUM(/2) * * * REMPLIR LE SEGMENT DESCRIPTEUR DE L'OBJET RIGIDITE * NLIGRP=NBNN NLIGRD=NBNN SEGINI,DESCR DO 1 IB=1,NLIGRP LISINC(IB)=MOTHER LISDUA(IB)=MOCHAL NOELEP(IB)=IB NOELED(IB)=IB 1 CONTINUE * IDESCR=DESCR SEGDES,DESCR * IF(IMAIL.GT.1)THEN MRIGID=IPRIGI SEGACT,MRIGID*MOD ENDIF * NLIGRE=NBNN LVAL=(NBNN*(NBNN+1))/2 * * NELRIG=NBELEM SEGINI,xMATRI IRIGEL(1,IMAIL)=IMAMOD IRIGEL(2,IMAIL)=0 IRIGEL(3,IMAIL)=IDESCR IRIGEL(4,IMAIL)=xMATRI IRIGEL(5,IMAIL)=0 IRIGEL(6,IMAIL)=0 IRIGEL(7,IMAIL)=2 IRIGEL(8,IMAIL)=0 * SEGDES,xMATRI,MRIGID SEGDES,MELEME*NOMOD CALL SORE2(NEF,IMAIL,IMODEL,IPCHE1,IPCHE3,IPCHE4,IPRIGI) IF (IERR.NE.0) RETURN 50 CONTINUE * END DO 99 CONTINUE DO 60 I=1,IFOI IMODEL=KMODEL(I) SEGDES,IMODEL*NOMOD 60 CONTINUE * END DO SEGDES,MMODEL*NOMOD * MCHELM = IPCHE2 SEGSUP,MCHELM MCHELM = IPCHE3 SEGSUP,MCHELM * RETURN END