C GRAF1 SOURCE AM 13/12/16 21:15:45 7825 SUBROUTINE GRAF1(IPMODL,IPCHE2,IPCHE1,IPCHL1,IRET) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) *____________________________________________________________________* * * * Sous-programme de l'op{rateur GRADIENT DE FLEXION * * * * Entr{es: * * * * IPMODL Pointeur sur un objet MMODEL * * IPCHE2 Pointeur sur un MCHAML de DEPLACEMENT * * IPCHE1 Pointeur sur un MCHAML de CARACTERISTIQUES * * * * Sortie: * * * * IPCHL1 Pointeur sur un MCHAML de gradients * * IRET 1 si succes , 0 sinon * * * * Auteurs, date de cr{ation: * * * * SUO X.Z Le 19/21/1986 * * Passage aux nouveux chamelems par P.DOWLATYARI le 28/03/91 * * * *____________________________________________________________________* * -INC CCOPTIO -INC CCHAMP -INC SMCHAML -INC SMMODEL -INC SMELEME -INC SMINTE -INC SMCOORD * SEGMENT,MWRK1 REAL*8 XDDL(LRE),XE(3,NBBB),GRADF(NGRAF) REAL*8 DDHOOK(NSTRS,NSTRS),DDHOMU(NSTRS,NSTRS) ENDSEGMENT * SEGMENT,MWRK2 REAL*8 SHPWRK(6,NBNO),BGF(NGRAF,LRE) ENDSEGMENT * SEGMENT,MWRK3 REAL*8 WORK(LW) ENDSEGMENT * SEGMENT,MWRK4 REAL*8 BPSS(3,3),XEL(3,NBBB),XDDLOC(LRE) ENDSEGMENT * SEGMENT NOTYPE CHARACTER*16 TYPE(NBTYPE) ENDSEGMENT * SEGMENT MVELCH REAL*8 VALMAT(NV1) ENDSEGMENT * SEGMENT MPTVAL INTEGER IPOS(NS) ,NSOF(NS) INTEGER IVAL(NCOSOU) CHARACTER*16 TYVAL(NCOSOU) ENDSEGMENT * CHARACTER*8 CMATE PARAMETER ( NINF=3 ) INTEGER INFOS(NINF) CHARACTER*(NCONCH) CONM LOGICAL lsupgf,lsupdp * IRET=1 MWRK1=0 MWRK2=0 MWRK3=0 MWRK4=0 MVELCH=0 NMAT = 0 IMESS= 0 NHRM = NIFOUR * * ACTIVATION DU CHAPEAU DE MODELE * MMODEL = IPMODL SEGACT MMODEL NSOUS = KMODEL(/1) * * Initialisation du CHAMELEM de GRADIENTS DE FLEXION * L1 = 19 N1 = NSOUS N3 = 6 SEGINI,MCHELM IPCHL1=MCHELM TITCHE = 'GRADIENT DE FLEXION' IFOCHE=IFOUR * * Boucle sur les zones {l{mentaires du MODELE * DO 500 ISOUS=1,NSOUS * * QUELQUES INITIALISATIONS * NGRAF= 0 MOGRAF=0 MODEPL=0 MOMATR=0 MOCARA=0 NDEP=0 NCAR = 0 IPMINT=0 IRTD1=1 NSTRS=0 IVAGRF=0 IVADEP=0 IVAMAT=0 IVACAR=0 NMATR=0 NMATF=0 * IMODEL=KMODEL(ISOUS) SEGACT IMODEL MELE=NEFMOD IPMAIL=IMAMOD CONM=CONMOD NFOR=FORMOD(/2) NMAT=MATMOD(/2) CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INAT) IF (CMATE.EQ.' ')THEN CALL ERREUR(251) SEGDES IMODEL,MMODEL SEGSUP MCHELM IRET=0 RETURN ENDIF * * ACTIVATION DU MAILLAGE * MELEME=IPMAIL SEGACT,MELEME NBNN =NUM(/1) NBELEM=NUM(/2) NBNO=NBNN * * INFORMATIONS SUR L'ELEMENT FINI * * CALL ELQUOI(MELE,0,5,IPINF,IMODEL) * IF (IERR.NE.0) THEN * SEGDES IMODEL,MMODEL * SEGSUP MCHELM * IRET=0 * RETURN * ENDIF * INFO=IPINF MFR=INFELE(13) * MINTE=INFELE(11) minte=infmod(7) MINTE1= INFMOD(8) NSTRS =INFELE(16) LW = INFELE( 7) LRE = INFELE( 9) LHOOK =INFELE(10) * * ACTIVATION DU SEGMENT D'INTEGRATION * SEGACT,MINTE NBPGAU=POIGAU(/1) C C CREATION DU TABLEAU INFOS C CALL IDENT(IPMAIL,CONM,IPCHE2,IPCHE1,INFOS,IRTD) IF (IRTD.EQ.0) GOTO 9990 * * NOMS DE COMPOSANTES OBLIGATOIRES A TROUVER DANS LES CHAMELEMS * if(lnomid(11).ne.0) then nomid=lnomid(11) segact nomid mograf=nomid ngraf=lesobl(/2) nfac=lesfac(/2) lsupgf=.false. else lsupgf=.true. CALL IDGRAF(MFR,IFOUR,MOGRAF,NGRAF,NFAC) endif * * NOMS DE COMPOSANTES DU DEPLACEMENT * if(lnomid(1).ne.0) then nomid=lnomid(1) segact nomid modepl=nomid ndep=lesobl(/2) nfac=lesfac(/2) lsupdp=.false. else lsupdp=.true. CALL IDDEPL(MFR,IFOUR,MODEPL,NDEP,NFAC) endif * * VERIFICATION DE PRESENCE DES COMPOSANTES * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' CALL KOMCHA(IPCHE2,IPMAIL,CONM,MODEPL, 1 MOTYPE,1,INFOS,3,IVADEP) SEGSUP NOTYPE IF (IERR.NE.0) THEN NGRAF=0 GO TO 9990 ENDIF * * RANGEMENT DE LA MATRICE DE HOOKE DANS UN TABLEAU DE * TRAVAIL UNIQUEMENT DANS LE CAS DE L'ELEMENT COQUE DST (MELE=93) * * CAS DES POUTRES ET TUYAUX : RECHERCHE DU VECTEUR LOCAL * NBROBL=0 NBRFAC=0 MOMATR=0 MOCARA=0 NCAR=0 NMATR=0 NMATF=0 IVECT=0 * * IF(MELE.EQ.93.AND.FORMOD(1).EQ.'MECANIQUE' 1 .AND.CMATE.EQ.'ISOTROPE') THEN NBROBL=2 NBRFAC=0 SEGINI NOMID MOMATR=NOMID LESOBL(1)='YOUN' LESOBL(2)='NU ' NMATR=NBROBL NMATF=NBRFAC * IF (IPCHE1.NE.0) THEN NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOMATR,MOTYPE, 1 1,INFOS,3,IVAMAT) SEGSUP NOTYPE ELSE MOTERR(1:8)='CARACTER' MOTERR(9:12)=NOMTP(MELE) MOTERR(13:20)='GRAF' CALL ERREUR(145) NMATR=0 NMATF=0 NGRAF=0 NOMID=MOMATR SEGSUP NOMID MOMATR=0 GOTO 9990 ENDIF IF (IERR.NE.0) GOTO 9990 * NMATT=NMATR+NMATF * MPTVAL=IVAMAT NBGMAT = 0 NELMAT = 0 DO 1108 IM=1,NMATT IF(IVAL(IM).NE.0)THEN MELVAL=IVAL(IM) NBGMAT=MAX(NBGMAT,VELCHE(/1)) NELMAT=MAX(NELMAT,VELCHE(/2)) ENDIF 1108 CONTINUE C NBROBL=1 NBRFAC=1 SEGINI NOMID MOCARA=NOMID LESOBL(1)='EPAI' LESFAC(1)='EXCE' NCAR=1 NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCARA, 1 MOTYPE,1,INFOS,3,IVACAR) SEGSUP NOTYPE IF (IERR.NE.0) GOTO 9990 ENDIF C IF(IVACAR.NE.0)THEN MPTVAL=IVACAR IPMELV=IVAL(1) CALL QUELCH(IPMELV,ICONS) IF(ICONS.NE.0)THEN CALL ERREUR(566) GOTO 9990 ENDIF * * CAS DES POUTRES ET TUYAUX * ELSE IF(MFR.EQ.7) THEN IF (CMATE.EQ.'SECTION') THEN NBROBL=0 NBRFAC=1 SEGINI NOMID MOCARA=NOMID LESFAC(1)='VECT' IVECT=1 * NBTYPE=1 SEGINI NOTYPE TYPE(1)='POINTEURPOINT ' ELSE IF(IFOUR.EQ.2) THEN NBROBL=4 NBRFAC=3 SEGINI NOMID MOCARA=NOMID LESOBL(1)='TORS' LESOBL(2)='INRY' LESOBL(3)='INRZ' LESOBL(4)='SECT' LESFAC(1)='SECY' LESFAC(2)='SECZ' LESFAC(3)='VECT' IVECT=1 * NBTYPE=7 SEGINI NOTYPE TYPE(1)='REAL*8' TYPE(2)='REAL*8' TYPE(3)='REAL*8' TYPE(4)='REAL*8' TYPE(5)='REAL*8' TYPE(6)='REAL*8' TYPE(7)='POINTEURPOINT ' ELSEIF(IFOUR.EQ.-1.OR.IFOUR.EQ.-2.OR.IFOUR.EQ.63) THEN NBRFAC=1 NBROBL=2 SEGINI NOMID MOCARA=NOMID LESOBL(1)= 'SECT' LESOBL(2)= 'INRZ' LESFAC(1)= 'SECY' * NBTYPE=1 SEGINI NOTYPE TYPE(1)='REAL*8' ENDIF ENDIF C C CARACTERISTIQUE POUR LES TUYAUX C ELSE IF (MFR.EQ.13) THEN NBROBL=2 NBRFAC=3 SEGINI NOMID MOCARA=NOMID LESOBL(1)='EPAI' LESOBL(2)='RAYO' LESFAC(1)='RACO' LESFAC(2)='CISA' LESFAC(3)='VECT' IVECT=1 C NBTYPE=5 SEGINI NOTYPE TYPE(1)='REAL*8' TYPE(2)='REAL*8' TYPE(3)='REAL*8' TYPE(4)='REAL*8' TYPE(5)='POINTEURPOINT ' C ENDIF NCARA=NBROBL NCARF=NBRFAC NCAR=NBROBL+NBRFAC C Verification de la presence des caracteristiques dans IPCHE1 IF (NCAR.NE.0) THEN IF (IPCHE1.NE.0) THEN MOTYPE=NOTYPE CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCARA,MOTYPE,1, . INFOS,3,IVACAR) SEGSUP,NOTYPE IF(IERR.NE.0) GOTO 9990 IF (IVACAR.NE.0) THEN MPTVAL=IVACAR IPMELV=IVAL(1) CALL QUELCH(IPMELV,ICONS) IF (ICONS.NE.0) THEN CALL ERREUR(566) GOTO 9990 ENDIF ENDIF * * CAS DES POUTRES : TRAITEMENT DES VECTEURS IF (IVECT.EQ.1) THEN MPTVAL=IVACAR IF (IVAL(NCAR).EQ.0) THEN C C MOT CLE VECT EN CAS DE CONVERSION C segsup mptval IVECT=2 NOMID=MOCARA C* SEGACT NOMID NBRFAC=NBRFAC+2 SEGADJ NOMID LESFAC(NBRFAC-2)='VX ' LESFAC(NBRFAC-1)='VY ' LESFAC(NBRFAC) ='VZ ' C NCARF=NBRFAC NCAR=NCARA+NCARF C CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCARA,MOTYCH, $ 1,INFOS,3,IVACAR) IF (IERR.NE.0) GOTO 9990 ENDIF ENDIF ELSE SEGSUP,NOTYPE MOTERR(1:8)='CARACTER' MOTERR(9:12)=NOMTP(MELE) MOTERR(13:20)='GRAF' CALL ERREUR(145) GOTO 9990 ENDIF ENDIF * C ===== C Cas d'un joint unidimensionnel JOI1 C Chargement des vecteurs stitués dans les caractéristiques matériau C ===== IF(MFR.EQ.75) THEN IF(IDIM.EQ.3) THEN NBROBL=6 NBRFAC=0 SEGINI NOMID MOMATR=NOMID LESOBL(1)='V1X' LESOBL(2)='V1Y' LESOBL(3)='V1Z' LESOBL(4)='V2X' LESOBL(5)='V2Y' LESOBL(6)='V2Z' NMATR=NBROBL NMATF=NBRFAC ELSE IF(IDIM.EQ.2) THEN NBROBL=2 NBRFAC=0 SEGINI NOMID MOMATR=NOMID LESOBL(1)='V1X' LESOBL(2)='V1Y' NMATR=NBROBL NMATF=NBRFAC ENDIF NBTYPE=1 SEGINI NOTYPE TYPE(1)='REAL*8' MOTYPE=NOTYPE * CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT) SEGSUP NOTYPE IF (IERR.NE.0) GOTO 9990 * NMATT=NMATR+NMATF * C IF(ISUP1.EQ.1)THEN CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE) IF(IERR.NE.0)THEN ISUP1=0 GOTO 9990 ENDIF ENDIF MPTVAL=IVAMAT NBGMAT = 0 NELMAT = 0 DO 11265 IM=1,NMATT IF(IVAL(IM).NE.0)THEN MELVAL=IVAL(IM) IF (CMATE.EQ.'SECTION') THEN NBGMAT=MAX(NBGMAT,IELCHE(/1)) NELMAT=MAX(NELMAT,IELCHE(/2)) ELSE NBGMAT=MAX(NBGMAT,VELCHE(/1)) NELMAT=MAX(NELMAT,VELCHE(/2)) ENDIF ENDIF 11265 CONTINUE nmattd=nmatt ivamtd= ivamat segdes nomid ENDIF * * CREATION DU MCHAML DE GRADIENT DE FLEXION * N2=NGRAF SEGINI,MCHAML ICHAML(ISOUS)=MCHAML IMACHE(ISOUS)=MELEME CONCHE(ISOUS)=CONMOD * INFCHE(ISOUS,1)=0 INFCHE(ISOUS,2)=0 INFCHE(ISOUS,3)=NHRM INFCHE(ISOUS,4)=MINTE INFCHE(ISOUS,5)=0 INFCHE(ISOUS,6)=5 * * RECHERCHE DES DIMENSIONS LES PLUS GRANDES * N1EL=0 N1PTEL=0 MPTVAL=IVADEP DO 178 IO=1,NDEP MELVAL=IVAL(IO) N1PTEL=MAX(N1PTEL,VELCHE(/1)) N1EL =MAX(N1EL ,VELCHE(/2)) 178 CONTINUE * IF(IVACAR.NE.0)THEN MPTVAL=IVACAR DO 179 IO=1,NCAR IF(IVAL(IO).NE.0) THEN MELVAL=IVAL(IO) N1PTEL=MAX(N1PTEL,VELCHE(/1)) N1EL =MAX(N1EL ,VELCHE(/2)) ENDIF 179 CONTINUE ENDIF * IF (N1PTEL.EQ.1.OR.NBPGAU.EQ.1) THEN N1PTEL=1 ELSE N1PTEL=NBPGAU ENDIF N1EL =MIN(N1EL ,NBELEM) * * CREATION DES MELVAL DU GRADIENT DE FLEXION * NS=1 NCOSOU=NGRAF SEGINI MPTVAL IVAGRF=MPTVAL NOMID=MOGRAF SEGACT NOMID DO 77 IGR=1,NGRAF TYPCHE(IGR)='REAL*8' NOMCHE(IGR)=LESOBL(IGR) N2PTEL=0 N2EL=0 SEGINI MELVAL IELVAL(IGR)=MELVAL IVAL(IGR)=MELVAL 77 CONTINUE SEGDES NOMID * C======================================================================= C NUMERO DES ETIQUETTES : C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT C DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR : C 5 CONTINUE C ELEMENT 5 ETIQUETTES 1005 2005 3005 4005 ... C 44 CONTINUE C ELEMENT 44 ETIQUETTES 1044 2044 3044 4044 ... C======================================================================= GOTO (99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 1 99,99,99,99,99,99,27,28,29,99,99,99,99,99,99,99,99,99,99,99, 2 99,29,99,44,99,99,99,99,49,99,99,99,99,99,99,99,99,99,99,99, 3 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 4 99,99,99,29,99,99,99,99,99,99,99,99,93,99,99,99,99),MELE C IF (MELE.EQ.265) GOTO 265 99 CONTINUE MOTERR(1:4)=NOMTP(MELE) MOTERR(9:12)='GRAF' IMESS = 86 GOTO 9990 * C ______________________ C | ELEMENTS COQ3 | C |______________________| 27 CONTINUE NBBB=NBNN SEGINI MWRK1,MWRK3 C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C DO 3027 IB=1,NBELEM C C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) C C ON CHERCHE LES DEPLACEMENTS C IE=0 MPTVAL=IVADEP DO 4027 IGAU=1,NBNN DO 4027 ICOMP=1,NDEP IE=IE+1 MELVAL=IVAL(ICOMP) IF (MELVAL.NE.0) THEN IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) ELSE XDDL(IE)=0.D0 ENDIF 4027 CONTINUE C CALL COQ3GF(XE,XDDL,GRADF,WORK) C C REMPLISAGE DU SEGMENT CONTENANT LES GRADIENT EN FLEXION C MPTVAL=IVAGRF DO 6027 IC=1,NGRAF MELVAL=IVAL(IC) IBMN=MIN(IB ,VELCHE(/2)) IF (IC.EQ.3.OR.IC.GE.6) THEN VELCHE(1,IBMN)=0.D0 ELSE VELCHE(1,IBMN)=GRADF(IC) ENDIF 6027 CONTINUE C 3027 CONTINUE GOTO 510 C ______________________ C | ELEMENT DKT | C |_____________________| 28 CONTINUE NBNO=NBNN NBBB=NBNN SEGINI MWRK1,MWRK2,MWRK4 DO 3028 IB=1,NBELEM C C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) C C ON CHERCHE LES DEPLACEMENTS C IE=0 MPTVAL=IVADEP DO 4028 IGAU=1,NBNN DO 4028 ICOMP=1,NDEP IE=IE+1 MELVAL=IVAL(ICOMP) IF (MELVAL.NE.0) THEN IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) ELSE XDDL(IE)=0.D0 ENDIF 4028 CONTINUE CALL VPAST(XE,BPSS) C BPSS STOCKE LA MATRICE DE PASSAGE CALL VCORLC (XE,XEL,BPSS) CALL MATVEC(XDDL,XDDLOC,BPSS,6) C C BOUCLE SUR LES POINTS DE GAUSS C DO 5028 IGAU=1,NBPGAU CALL BGFDKT(IGAU,MELE,LRE,IFOUR,XEL,BGF) CALL BGRDEP(BGF,NGRAF,XDDLOC,LRE,GRADF) C C REMPLISSAGE DU SEGMENT CONTENANT LES GRAFLEXI C MPTVAL=IVAGRF DO 9028 IC=1,NGRAF MELVAL=IVAL(IC) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) IF (IC.EQ.3.OR.IC.GE.6) THEN VELCHE(IGMN,IBMN)=0.D0 ELSE VELCHE(IGMN,IBMN)=GRADF(IC) ENDIF 9028 CONTINUE 5028 CONTINUE 3028 CONTINUE GOTO 510 C ______________________ C | ELEMENT DST | C |_____________________| 93 CONTINUE NBNO=NBNN NBBB=NBNN NV1=NMATT SEGINI MWRK1,MWRK2,MWRK3,MWRK4,MVELCH DO 3093 IB=1,NBELEM C C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) C C ON CHERCHE LES DEPLACEMENTS C IE=0 MPTVAL=IVADEP DO 4093 IGAU=1,NBNN DO 4093 ICOMP=1,NDEP IE=IE+1 MELVAL=IVAL(ICOMP) IF (MELVAL.NE.0) THEN IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) ELSE XDDL(IE)=0.D0 ENDIF 4093 CONTINUE C CALL VPAST(XE,BPSS) C BPSS STOCKE LA MATRICE DE PASSAGE CALL VCORLC (XE,XEL,BPSS) CALL MATVEC(XDDL,XDDLOC,BPSS,6) C C ON CHERCHE LES EPAISEURS ET ON LES MOYENNE, C LES EXCENTREMENTS ET ON LES MOYENNE. C EPAIST=0.D0 EXCEN=0.D0 MPTVAL=IVACAR DO 8093 IGAU=1,NBPGAU MELVAL=IVAL(1) IF (MELVAL.NE.0) THEN IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) EPAIST=EPAIST+VELCHE(IGMN,IBMN) ELSE EPAIST=0.D0 ENDIF * MELVAL=IVAL(2) IF (MELVAL.NE.0) THEN IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) EXCEN=EXCEN+VELCHE(IGMN,IBMN) ELSE EXCEN=0.D0 ENDIF 8093 CONTINUE EPAIST=EPAIST/NBPGAU EXCEN=EXCEN/NBPGAU C C BOUCLE SUR LES POINTS DE GAUSS C DO 5093 IGAU=1,NBPGAU MPTVAL=IVAMAT DO 9193 IM=1,NMATT IF (IVAL(IM).NE.0) THEN MELVAL=IVAL(IM) IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) VALMAT(IM)=VELCHE(IGMN,IBMN) ELSE VALMAT(IM)=0.D0 ENDIF 9193 CONTINUE IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOHDST(VALMAT,CMATE,IFOUR,NSTRS,DDHOOK,IRTD1) CALL HOOKMU(EPAIST,0.D0,LHOOK,DDHOOK,DDHOMU) CALL ZERO(BGF,NGRAF,LRE) C C CALCUL DES FONCTIONS HS4,HS5 ET HS6 C CALL HS456(XEL,NSTRS,DDHOMU,WORK(1),WORK(10),WORK(19)) C C TERMES DE LA MATRICE DE BGF RELATIFS C AUX DEFORMATONS DE FLEXION C CALL BGFDST(IGAU,XEL,NGRAF,QSIGAU,ETAGAU, 1 WORK(1),WORK(10),WORK(19),BGF) CALL BGRDEP(BGF,NGRAF,XDDLOC,LRE,GRADF) C C REMPLISSAGE DU SEGMENT CONTENANT LES GRAFLEXI C MPTVAL=IVAGRF DO 9093 IC=1,NGRAF MELVAL=IVAL(IC) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) IF (IC.EQ.3.OR.IC.GE.6) THEN VELCHE(IGMN,IBMN)=0.D0 ELSE VELCHE(IGMN,IBMN)=GRADF(IC) ENDIF 9093 CONTINUE 5093 CONTINUE 3093 CONTINUE GOTO 510 C _____________________________________ C | COQUES A 4 NOEUDS COQ4 | C |___________________________________| 49 CONTINUE NBNO=NBNN NBBB=NBNN SEGINI MWRK1,MWRK2,MWRK4 DO 3049 IB=1,NBELEM C C ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) C CALL CQ4LOC(XE,XEL,BPSS,IERT,IUN) C IERT=1 NODI TROPPO VICINI C IERT=2 NODI ELEMENTO NON COMPLANARI IF(IERT.NE.0)THEN IF(IERT.EQ.1)IMESS=323 IF(IERT.EQ.2)IMESS=322 GO TO 9990 ENDIF C C ON CHERCHE LES DEPLACEMENTS C IE=0 MPTVAL=IVADEP DO 2049 IGAU=1,NBNN DO 2049 ICOMP=1,NDEP IE=IE+1 MELVAL=IVAL(ICOMP) IF (MELVAL.NE.0) THEN IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) ELSE XDDL(IE)=0.D0 ENDIF 2049 CONTINUE C CALL MATVEC(XDDL,XDDLOC,BPSS,8) C C BOUCLE SUR LES POINTS DE GAUSS C DO 4049 IGAU=1,NBPGAU C C APPEL A BGFCQ4 C CALL BGFCQ4(IGAU,XEL,SHPTOT,SHPWRK,BGF,DJAC,IERT) C IERT=1 JACOBIANO <= 0 IF(IERT.EQ.1)THEN IMESS=321 GO TO 9990 ENDIF C CALL BGRDEP(BGF,NGRAF,XDDLOC,LRE,GRADF) C C REMPLISSAGE DU SEGMENT CONTENANT LES GRAFLEXI C MPTVAL=IVAGRF DO 9049 IC=1,NGRAF MELVAL=IVAL(IC) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) IF (IC.EQ.3.OR.IC.GE.6) THEN VELCHE(IGMN,IBMN)=0.D0 ELSE VELCHE(IGMN,IBMN)=GRADF(IC) ENDIF 9049 CONTINUE C 4049 CONTINUE 3049 CONTINUE GO TO 510 C C COQ2 C 44 CONTINUE NBNO=NBNN SEGINI MWRK1,MWRK2 C NDDD=NDEP IF (IFOUR.EQ.-3) NDDD=NDEP-3 DO 3044 IB=1,NBELEM C C ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) C C ON CHERCHE LES DEPLACEMENTS C MPTVAL=IVADEP IE=1 DO 2044 IGAU=1,NBNN DO 2044 ICOMP=1,NDDD MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 2044 CONTINUE IF (IFOUR.EQ.-3) THEN XDDL(IE)=UZDPG XDDL(IE+1)=RYDPG XDDL(IE+2)=RXDPG ENDIF C C BOUCLE SUR LES POINTS DE GAUSS C DO 4044 IGAU=1,NBPGAU MPTVAL=IVACAR IF (IVAL(2).NE.0) THEN MELVAL=IVAL(2) IBMN=MIN(IB,VELCHE(/2)) EXCEN=VELCHE(1,IBMN) ELSE EXCEN=0.D0 ENDIF C APPEL A BGFCQ2 C CALL BGFCQ2(BGF,NGRAF,DJAC,IGAU,IFOUR,XE,NHRM,QSIGAU,POIGAU, . EXCEN,1.D0,IRR,XDPGE,YDPGE) C C GESTION D'ERREUR C IF (IRR.EQ.1) THEN INTERR(1)=IB CALL ERREUR(255) GOTO 9990 ELSE IF(IRR.EQ.2) THEN INTERR(1)=IB CALL ERREUR(256) GOTO 9990 ENDIF C CALL BST(BGF,XDDL,LRE,NGRAF,GRADF) C C REMPLISSAGE DU SEGMENT CONTENANT LES GRADIENTS DE FLEXION C MPTVAL=IVAGRF DO 9044 ICOMP=1,NGRAF MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGMN,IBMN)=GRADF(ICOMP) 9044 CONTINUE 4044 CONTINUE 3044 CONTINUE C GOTO 510 C C POUTRE, TUYA, TIMO C 29 CONTINUE NBNO=NBNN NBBB=NBNN SEGINI MWRK1,MWRK3 DO 3029 IB=1,NBELEM C C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) C C ON CHERCHE LES DEPLACEMENTS C IE=0 MPTVAL=IVADEP DO 4029 IGAU=1,NBNN DO 4029 ICOMP=1,NDEP IE=IE+1 MELVAL=IVAL(ICOMP) IF (MELVAL.NE.0) THEN IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) ELSE XDDL(IE)=0.D0 ENDIF 4029 CONTINUE C C ON CHERCHE LES CARACTERISTIQUES DE L ELEMENT IB C CALL ZERO(WORK,NCAR,1) DO 5029 IGAU=1,NBNN MPTVAL=IVACAR DO 6029 IC=1,NCAR IF(IVAL(IC).NE.0) THEN MELVAL=IVAL(IC) IBMN=MIN(IB,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) IF(IGMN.GT.0.AND.IBMN.GT.0) THEN WORK(IC)=WORK(IC)+VELCHE(IGMN,IBMN) ELSE WORK(IC)=0. ENDIF ELSE WORK(IC)=0. ENDIF IF (IGAU.EQ.NBNN) WORK(IC)=WORK(IC)/NBNN 6029 CONTINUE 5029 CONTINUE C C CAS OU ON A LU LE MOT VECTEUR C IF (IFOUR.EQ.2) THEN C IF (IVECT.EQ.1) THEN IF (IVAL(NCAR).NE.0) THEN MELVAL=IVAL(NCAR) IBMN=MIN(IB,IELCHE(/2)) IP=IELCHE(1,IBMN) IREF=(IP-1)*(IDIM+1) DO 6129 IC=1,IDIM WORK(NCAR+IC-1)=XCOOR(IREF+IC) 6129 CONTINUE ELSE DO 6229 IC=1,IDIM WORK(NCAR+IC-1)=0.D0 6229 CONTINUE ENDIF ENDIF C ENDIF C C CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE C EQUIVALENTE IF(MELE.EQ.42) THEN CISA=WORK(4) VX=WORK(5) VY=WORK(6) VZ=WORK(7) CALL TUYCAR(WORK,CISA,VX,VY,VZ,KERRE,2) ENDIF C C ON CALCULE LES GRADIENTS C IF(MELE.EQ.84) THEN C IF(CMATE.EQ.'SECTION') THEN IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN CALL TIMGF2(XE,XDDL,WORK(12),WORK(25)) ELSE CALL TIMGF1(XE,XDDL,WORK(1),WORK(12),WORK(25)) ENDIF ELSE C IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN CALL TIMGF2(XE,XDDL,WORK(12),WORK(25)) C ELSE CALL TIMGF1(XE,XDDL,WORK(7),WORK(12),WORK(25)) ENDIF ENDIF ELSE C IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN CALL POUGF2(XE,XDDL,WORK,WORK(12),WORK(25)) ELSE C CALL POUGF1(XE,XDDL,WORK,WORK(12),WORK(25)) ENDIF ENDIF * REMPLISSAGE DO iGau=1,NBPGAU MPTVAL=IVAGRF DO i=1,NGRAF MELVAL=IVAL(i) IGMN=MIN(iGau,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) * IDECA=11+I+(IGAU-1)*NGRAF VELCHE(IGMN,IBMN)=WORK(I) ENDDO ENDDO 3029 CONTINUE GOTO 510 C C JOINT UNIDIMENSIONNELS JOI1 C 265 CONTINUE NBNO=NBNN NBBB=NBNN SEGINI MWRK1,MWRK3,MWRK4 DO 3265 IB=1,NBELEM C C RANGEMENT DES CARACTERISTIQUES DANS WORK C MPTVAL=IVAMAT DO IC=1,NMATT IF(IVAL(IC).NE.0) THEN MELVAL=IVAL(IC) IBMN=MIN(IB,VELCHE(/2)) WORK(IC)=VELCHE(1,IBMN) ELSE WORK(IC)=0.D0 ENDIF END DO C CALL MAPALU(NMATT,WORK,BPSS,IDIM) C C ON CHERCHE LES DEPLACEMENTS C IE=0 MPTVAL=IVADEP DO 4265 IGAU=1,NBNN DO 4265 ICOMP=1,NDEP IE=IE+1 MELVAL=IVAL(ICOMP) IF (MELVAL.NE.0) THEN IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) ELSE XDDL(IE)=0.D0 ENDIF 4265 CONTINUE C C CALCUL DES DEPLACEMENTS LOCAUX C IAW1 = 101 IAW2 = IAW1 + LRE CALL JOILOC(XDDL,BPSS,WORK(IAW1),WORK(IAW2),LRE,IDIM) C C ON CALCULE LES GRADIENTS C CALL JOIGF1(XDDL,WORK,LRE,NGRAF,IDIM) * REMPLISSAGE DO iGau=1,NBPGAU MPTVAL=IVAGRF DO i=1,NGRAF MELVAL=IVAL(i) IGMN=MIN(iGau,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) IDECA=11+I+(IGAU-1)*NGRAF VELCHE(IGMN,IBMN)=WORK(IDECA) ENDDO ENDDO 3265 CONTINUE GOTO 510 C C DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE IA C 510 CONTINUE * Desactivation des segments * IF (MWRK1.NE.0) SEGSUP,MWRK1 IF (MWRK2.NE.0) SEGSUP,MWRK2 IF (MWRK3.NE.0) SEGSUP,MWRK3 IF (MWRK4.NE.0) SEGSUP,MWRK4 IF (MVELCH.NE.0) SEGSUP,MVELCH * CALL DTMVAL(IVADEP,1) * CALL DTMVAL(IVAMAT,1) * CALL DTMVAL(IVACAR,1) * CALL DTMVAL(IVAGRF,1) * NOMID=MODEPL if(lsupdp)SEGSUP NOMID NOMID=MOGRAF if(lsupgf)SEGSUP NOMID IF (MOMATR.NE.0) THEN NOMID=MOMATR SEGSUP NOMID ENDIF IF (MOCARA.NE.0) THEN NOMID=MOCARA SEGSUP NOMID ENDIF * * SEGSUP INFO SEGDES,IMODEL,MELEME SEGDES,MCHAML,MINTE * 500 CONTINUE SEGDES,MMODEL,MCHELM * CALL DTCHAM(IPCHE2) * RETURN * 9990 CONTINUE * * ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR * IRET=0 * * Gestion des messages d'erreur * IF (IMESS.NE.0) THEN INTERR(1) = IB CALL ERREUR(IMESS) ENDIF * IF (MWRK1.NE.0) SEGSUP,MWRK1 IF (MWRK2.NE.0) SEGSUP,MWRK2 IF (MWRK3.NE.0) SEGSUP,MWRK3 IF (MWRK4.NE.0) SEGSUP,MWRK4 IF (MVELCH.NE.0) SEGSUP,MVELCH * CALL DTMVAL(IVADEP,1) * CALL DTMVAL(IVAMAT,1) * CALL DTMVAL(IVACAR,1) * CALL DTMVAL(IVAGRF,3) * IF(MODEPL.NE.0.and.lsupdp) THEN NOMID=MODEPL SEGSUP NOMID ENDIF * IF(MOGRAF.NE.0)THEN NOMID=MOGRAF if(lsupgf)SEGSUP NOMID ENDIF * IF (MOCARA.NE.0) THEN NOMID=MOCARA SEGSUP NOMID ENDIF * IF (MOMATR.NE.0) THEN NOMID=MOMATR SEGSUP NOMID ENDIF * SEGDES MELEME SEGDES IMODEL * SEGDES MMODEL IF (IPCHE1.NE.0) THEN MCHELM=IPCHE1 SEGDES MCHELM ENDIF * * IF (IPCHE2.NE.0) CALL DTCHAM(IPCHE2) SEGDES MINTE * SEGSUP INFO RETURN END