C HOOK2D SOURCE MB234859 26/01/19 21:15:19 12454 SUBROUTINE HOOK2D(IPMODE,CMATE,INAT,MFR,IVAMAT,NMATT,IVACAR, 1 NCARR,NPINT,IVARI,NVART,IVAHOO,KCAS,NBPGAU, 2 LHOOK,LW,LASURF,IPORE,IRET) C_______________________________________________________________________ C C Calcul de la matrice de HOOKE C C Entr{es: C ________ C C IPMODE Pointeur sur un segment imodel C CMATE Type du mat{riau (isotrope, orthotrope .....) C INAT Numero de plasticite C MFR Numero de formulation C IVAMAT Pointeur sur un tableau de MELVAL de MATERIAU C NMATT Nombre de composantes de materiau C IVACAR Pointeur sur un tableau de MELVAL de CARACTERISTIQUES C NCARR Nombre de composantes de caracteristiques C NPINT Nombre de points d integration C IVARI Pointeur sur un tableau de MELVAL de VARIABLES INTERNES C NVART Nombre de composantes de variables internes C IVAHOO Pointeur sur le MELVAL de HOOKE C NBPGAU Nombre de points d integration C LHOOK Taille de la matrice de HOOKE C LW Taille du tableau de travail WORK C LASURF 1 si on veut la matrice en surface de ref, 0 sinon C IPORE dimension pour milieux poreux C C Sorties: C ________ C C IRET=1 OU 0 suivant succes ou pas C C C CODE L EBERSOLT MAI 84 C C Passage aux nouveaux CHAMELEMs par I.Monnier le 18.06.90 C ADDITION DES MATERIAUX ORTHOTROPE ET ANISOTROPE C PAR P.DOWLATYARI DEC. 90 C_______________________________________________________________________ C IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC CCHAMP -INC SMMODEL -INC SMELEME -INC SMCOORD -INC SMINTE -INC SMCHAML -INC SMLREEL -INC TMPTVAL SEGMENT WRK2 REAL*8 XE(3,NBNN),TXR(IDIM,IDIM) REAL*8 XLOC(3,3),XGLOB(3,3) REAL*8 D1HOOK(LHOOK,LHOOK),ROTHOO(LHOOK,LHOOK) ENDSEGMENT * SEGMENT WRK4 REAL*8 SHPWRK(6,NBNN), BGENE(NSTRS,LRE) REAL*8 BPSS(3,3), XEL(3,NBNN) ENDSEGMENT * SEGMENT TRAV REAL*8 VALCAR(LW),VALMAT(NMATT),VAR(NVART) REAL*8 DDHOOK(LHOOK,LHOOK),DDHOMU(LHOOK,LHOOK) REAL*8 COBMA(LHOOK) ENDSEGMENT C DIMENSION CRIGI(12),CMASS(12),S(20) CHARACTER*8 CMATE PARAMETER(XZER=0.D0,X774=.774596669241483D0) C IRET=1 IGAU=0 IB =0 IMODEL=IPMODE MELE=NEFMOD C C RECUPERATION DES TAILLES DE TABLEAUX C MELVAL=IVAHOO NBPTEL=IELCHE(/1) NEL =IELCHE(/2) MPTVAL=IVAMAT NBGMAT = 0 NELMAT = 0 DO 1000 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 1000 CONTINUE MPTVAL=IVACAR DO 1001 IO=1,NCARR IF(IVAL(IO).NE.0)THEN MELVAL=IVAL(IO) 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 1001 CONTINUE IF (IVARI.NE.0) THEN MPTVAL=IVARI DO 1002 IO=1,NVART MELVAL=IVAL(IO) IF(MELVAL.NE.0)THEN 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 1002 CONTINUE ENDIF C C INITIALISATION DES TABLEAUX DE TRAVAIL C IF(MFR.EQ.15.AND.NBPGAU.EQ.1) THEN DO 10 I=1,NBPGAU S(I)= XZER 10 CONTINUE ELSE IF(MFR.EQ.15.AND.NBPGAU.EQ.3) THEN DO 11 I=1,NBPGAU S(1)=-X774 S(2)= XZER S(3)= X774 11 CONTINUE ENDIF * NMAT1=NMATT * cette sequence est presente car la troisieme composante * (eventuellement) obligatoire est la septieme composante du materiau IF(INAT.EQ.26) NMATT=NMATT+4 SEGINI TRAV * IF ((CMATE.EQ.'ORTHOTRO'.OR.CMATE.EQ.'ANISOTRO'.OR. 1 CMATE.EQ.'UNIDIREC').OR.(MFR.EQ.55)) THEN C RENSEIGNEMENTS SUR LE MAILLAGE MELEME=IMAMOD C SEGACT MELEME NBNN=NUM(/1) SEGINI WRK2 * IF(MFR.EQ.55)THEN LRE=NBNN*IDIM NSTRS=LHOOK SEGINI,WRK4 ENDIF * ENDIF C C C IF (((CMATE.EQ.'ORTHOTRO'.OR.CMATE.EQ.'ANISOTRO'.OR. 1 CMATE.EQ.'UNIDIREC').AND.(MFR.EQ.1.OR.MFR.EQ.33)) 1 .OR.(MFR.EQ.55)) THEN C C RENSEIGNEMENTS SUR LE MAILLAGE C NBNO=NBNN IF(MFR.EQ.33) NBNO=IPORE * * RECUPERATION DES FONCTIONS DE FORME ET LEURS DERIVEES AU CENTRE DE * L'ELEMENT POUR LE CALCUL DES AXES LOCAUX IELE=NUMGEO(MELE) CALL RESHPT(1,NBNO,IELE,MELE,NPINT,IPT1,IRT1) MINTE2=IPT1 SEGACT MINTE2 ENDIF C C Boucle sur les elements C DO 1100 IB=1,NEL C IF ((CMATE.EQ.'ORTHOTRO'.OR.CMATE.EQ.'ANISOTRO'.OR. 1 CMATE.EQ.'UNIDIREC').AND.(MFR.EQ.1.OR.MFR.EQ.33)) THEN C C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) C C CALCUL DES AXES LOCAUX C NBSH=MINTE2.SHPTOT(/2) CALL RLOCAL(XE,MINTE2.SHPTOT,NBSH,NBNN,TXR) if (nbsh.eq.-1) then call erreur(525) return endif ENDIF C C Boucle sur les points C DO 1101 IGAU=1,NBPTEL C MPTVAL=IVAMAT DO 1005 IM=1,NMAT1 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 1005 CONTINUE * * cette sequence est presente car la troisieme composante * (eventuellement) obligatoire est la septieme composante du materiau IF(INAT.EQ.26) THEN VALMAT(7)=VALMAT(3) DO 1006 ICOMP=3,6 VALMAT(ICOMP)=0.D0 1006 CONTINUE ENDIF C IF(INAT.EQ.26.OR.INAT.EQ.29.OR.INAT.EQ.30.OR. & INAT.EQ.62.OR.INAT.EQ.64.OR.INAT.EQ.65.OR.INAT.EQ.118.OR. & INAT.EQ.193.OR.INAT.EQ.194.OR.INAT.EQ.195.OR.INAT.EQ.196) THEN MPTVAL=IVARI DO 1007 IM=1,NVART IF (IVAL(IM).NE.0) THEN MELVAL=IVAL(IM) IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) VAR(IM)=VELCHE(IGMN,IBMN) ELSE VAR(IM)=0.D0 ENDIF 1007 CONTINUE ENDIF C IF(MFR.EQ.61)THEN DO ICOMP=1,NCARR MPTVAL=IVACAR MELVAL=IVAL(ICOMP) IF (MELVAL.NE.0) THEN IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) VALCAR(ICOMP)=VELCHE(IGMN,IBMN) ELSE VALCAR(ICOMP)=0.D0 ENDIF ENDDO ENDIF C IF(MFR.EQ.7.OR.MFR.EQ.13.OR.MFR.EQ.15. 1 OR.MFR.EQ.17) THEN C C ON CHERCHE LES CARACTERISTIQUES DE L ELEMENT IB C IF(CMATE.EQ.'SECTION ') THEN C MPTVAL=IVAMAT MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) IGMN=MIN(IGAU,IELCHE(/1)) IPMODL=IELCHE(IGMN,IBMN) MELVAL=IVAL(2) IBMN=MIN(IB ,IELCHE(/2)) IGMN=MIN(IGAU,IELCHE(/1)) IPCAR=IELCHE(IGMN,IBMN) CALL FRIGIE(IPMODL,IPCAR,CRIGI,CMASS) C ELSEIF (MFR.EQ.15) THEN C IE=1 DO IC=1,3,2 MPTVAL=IVACAR DO ICOMP=1,NCARR MELVAL=IVAL(ICOMP) IF (MELVAL.NE.0) THEN IGMN=MIN(IC,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) VALCAR(IE)=VELCHE(IGMN,IBMN) ELSE VALCAR(IE)=0.D0 ENDIF IE=IE+1 ENDDO ENDDO C ELSE C DO 1010 ICOMP=1,NCARR MPTVAL=IVACAR MELVAL=IVAL(ICOMP) IF (MELVAL.NE.0) THEN IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) VALCAR(ICOMP)=VELCHE(IGMN,IBMN) ELSE VALCAR(ICOMP)=0.D0 ENDIF 1010 CONTINUE ENDIF ENDIF C IF(MFR.EQ.27.OR.MFR.EQ.49) THEN C C ON CHERCHE LA SECTION DE L'ELEMENT IB C MPTVAL=IVACAR MELVAL=IVAL(1) IF (MELVAL.NE.0) THEN IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) SECT=VELCHE(IGMN,IBMN) ELSE SECT=0.D0 ENDIF ENDIF C C ON CHERCHE L'EPAISSEUR DU JOINT GENERALISE IB C IF(MFR.EQ.55) THEN MPTVAL=IVACAR MELVAL=IVAL(1) IF (MELVAL.NE.0) THEN IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) EPAIST=VELCHE(IGMN,IBMN) ELSE EPAIST=0.D0 ENDIF C IF(EPAIST.EQ.0.D0) THEN CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) IF(MELE.EQ.170)THEN CALL JO2LOC(XE,MINTE2.SHPTOT,NBNN,XEL,BPSS,NOQUAL) CALL BJO2GN(IGAU,MFR,IFOUR,NIFOUR,XE,XEL,BPSS, . MINTE2.SHPTOT,SHPWRK,EPAIST,BGENE,DJAC,XDPGE,YDPGE,IERT) ELSEIF(MELE.EQ.171)THEN CALL JT3LOC(XE,MINTE2.SHPTOT,NBNN,XEL,BPSS,NOQUAL) CALL BJT3G(IGAU,MFR,IFOUR,NIFOUR,XE,XEL,BPSS, . MINTE2.SHPTOT,SHPWRK,EPAIST,BGENE,DJAC,IERT) ELSEIF(MELE.EQ.172)THEN CALL JO4LOC(XE,MINTE2.SHPTOT,NBNN,XEL,BPSS,NOQUAL) CALL BJO4G(IGAU,XE,XEL,BPSS,MINTE2.SHPTOT,SHPWRK,EPAIST, . BGENE,DJAC,IERT) ENDIF ENDIF ENDIF C C Prise en compte de l'epaisseur et de l'excentrement C dans le cas des coques minces avec ou sans cisaillement C transverse C IF ((CMATE.EQ.'ISOTROPE'.OR.CMATE.EQ.'ORTHOTRO'.OR. 1 CMATE.EQ.'UNIDIREC').AND. 2 (MFR.EQ.3.OR.MFR.EQ.9)) THEN MPTVAL=IVACAR MELVAL=IVAL(1) IF (MELVAL.NE.0) THEN IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) EPAIST=VELCHE(IGMN,IBMN) ELSE CALL ERREUR(527) IRET=0 GOTO 9000 ENDIF C IF(LASURF.EQ.0) THEN EXCEN = 0.D0 ELSE MELVAL=IVAL(2) IF (MELVAL.NE.0) THEN IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) EXCEN=VELCHE(IGMN,IBMN) ELSE EXCEN=0.D0 ENDIF ENDIF ENDIF C_______________________________________________________________________ C C TRAITEMENT SUIVANT TYPE DE MATERIAU C_______________________________________________________________________ C IF (CMATE.EQ.'ISOTROPE'.OR.CMATE.EQ.'ZONE_COH') THEN CALL HOOKIS(VALMAT,VALCAR,VAR,MFR,IB,IGAU,EXCEN,EPAIST, + INAT,MELE,NPINT,IFOUR,KCAS,NBGMAT,NELMAT, + S,SECT,LHOOK,DDHOMU,DDHOOK, + COBMA,XMOB,IRET) C ELSE IF (CMATE.EQ.'ORTHOTRO') THEN CALL HOOKOR(VALMAT,IB,IGAU,MFR,EXCEN,EPAIST, + MELE,NPINT,IFOUR,KCAS,NBGMAT,NELMAT,SECT,LHOOK, + TXR,XLOC,XGLOB,D1HOOK,ROTHOO,DDHOMU,DDHOOK, + COBMA,XMOB,IRET) C ELSE IF (CMATE.EQ.'ANISOTRO') THEN CALL HOOKAN(VALMAT,IB,IGAU,MFR,IFOUR,KCAS,NBGMAT,NELMAT, + SECT,LHOOK,TXR,XLOC,XGLOB,D1HOOK,ROTHOO,DDHOOK, + MELE,COBMA,XMOB,IRET) C ELSE IF (CMATE.EQ.'UNIDIREC') THEN CALL HOOKUN(VALMAT,IB,IGAU,MFR,EXCEN,EPAIST, + MELE,NPINT,IFOUR,KCAS,NBGMAT,NELMAT,SECT,LHOOK, + TXR,XLOC,XGLOB,D1HOOK,ROTHOO,DDHOMU,DDHOOK, + COBMA,XMOB,IRET) C ELSE IF (CMATE.EQ.'HOMOGENE') THEN CALL HOOKHO(VALMAT,IB,IGAU,MFR,NBGMAT,NELMAT,SECT, + LHOOK,DDHOOK,IRET) C ELSE IF (CMATE.EQ.'SECTION ') THEN CALL HOOKSE(VALMAT,IB,IGAU,MFR,CRIGI,IFOUR, + NBGMAT,NELMAT,SECT,LHOOK,DDHOOK,IRET) C ENDIF C IF (IRET.EQ.0) THEN IF (MFR.EQ.3.AND.NPINT.NE.0) THEN CALL ERREUR(251) ELSE MOTERR(1:8)=NOMFR(MFR/2+1) CALL ERREUR(193) ENDIF GOTO 1200 ENDIF C C C REMPLISSAGE DU SEGMENT IVAHOO C MELVAL=IVAHOO MLREEL=IELCHE(IGAU,IB) KO=0 DO JO=1,LHOOK DO IO=1,LHOOK KO=(JO-1)*LHOOK + IO PROG(KO)=DDHOOK(IO,JO) ENDDO ENDDO 1101 CONTINUE 1100 CONTINUE * section non // pour les activations en nomod call oooprl(1) DO 1102 IB=1,NEL DO 1103 IGAU=1,NBPTEL MLREEL=IELCHE(IGAU,IB) SEGACT,MLREEL*NOMOD 1103 continue 1102 continue call oooprl(0) C 1200 CONTINUE IF ((CMATE.EQ.'ORTHOTRO'.OR.CMATE.EQ.'ANISOTRO'.OR. 1 CMATE.EQ.'UNIDIREC').AND.(MFR.EQ.1.OR.MFR.EQ.33)) THEN ** SEGDES MINTE2 ENDIF * 9000 CONTINUE IF ((CMATE.EQ.'ORTHOTRO'.OR.CMATE.EQ.'ANISOTRO'.OR. 1 CMATE.EQ.'UNIDIREC')) THEN ** SEGDES MELEME SEGSUP WRK2 ENDIF IF (MFR.EQ.55) SEGSUP WRK4 SEGSUP TRAV RETURN END