C RIGI2 SOURCE PV090527 26/04/30 21:16:19 12529 SUBROUTINE RIGI2(MATE,MELE,IPMAIL,IPMINT,NBPGAU,LRE,NSTRS, & IVAMAT,IVACAR,CMATE,MFR,NBGMAT,NELMAT,IMAT,LHOOK,NMATT, & IPORE,NDDL,IPMATR,IIPDPG,NCAR1,MELPHA,NOER) *---------------------------------------------------------------------* * __________________________ * * | | * * | CALCUL DE LA RIGIDITE | * * |________________________| * * * * massif, liquide, 'surface libre', poreux et joints poreux, * * incompressible * * * *---------------------------------------------------------------------* * * * ENTREES : * * ________ * * * * MATE Numero du materiau * * MELE Numero de l'element fini * * IPMAIL Pointeur sur un segment MELEME * * IPMINT Pointeur sur un segment MINTE * * NBPGAU Nombre de point d'integration pour la rigidite * * LRE Nombre de ddl dans la matrice de rigidite * * NSTRS Nombre de composante de contraintes/deformations * * IVAMAT Pointeur sur un segment MPTVAL pour le materiau ou * * pour une matrice de hooke * * IVACAR Pointeur sur un segment MPTVAL de caractéristiques * * CMATE Nom du materiau * * MFR Numero de la formulation element fini * * NBGMAT Taille maxi des melval du materiau (pt de gauss) * * NELMAT Taille maxi des melval du materiau (No d'element) * * IMAT (2 il y a une matrice de HOOKE,1 non ) * * NMATT Nombre de composante de materiau (IMAT=1) * * LHOOK Dimension de la matrice de Hooke * * IPORE Nombre de fonctions de forme * * NDDL Nombre de degre de liberte * * * * SORTIES : * * ________ * * * * IPMATR pointeur sur la rigidite de la sous-zone * * * *---------------------------------------------------------------------* IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC CCHAMP -INC CCREEL -INC SMCHAML -INC SMINTE -INC SMELEME -INC SMRIGID -INC SMCOORD -INC SMLREEL -INC TMPTVAL SEGMENT WRK1 REAL*8 DDHOOK(LHOOK,LHOOK) ,DDHOMU(LHOOK,LHOOK) REAL*8 REL(LRE,LRE) ,RINT(LRE,LRE) , XE(3,NBBB) ENDSEGMENT * SEGMENT WRK2 REAL*8 SHPWRK(6,NBNO) ,BGENE(LHOOK,LRE) ENDSEGMENT * SEGMENT WRK3 REAL*8 BPSS(3,3),XEL(3,NBBB) REAL*8 XNTH(LPP,LPP),XNTB(LPP,LPP),XNTT(LPP) ENDSEGMENT * SEGMENT WRK5 REAL*8 XGENE(NSTN,LRN) ENDSEGMENT * SEGMENT WRK55 REAL*8 YGENE(NCOT,NBNN),COBMA(LHOOK) ENDSEGMENT * SEGMENT WRK555 REAL*8 XREL(LRN,LRN),COBB(NSTN),CPBB(NSTN),KKBB(NSTN,NSTN) ENDSEGMENT * SEGMENT WRK8 REAL*8 XLOC(3,3),XGLOB(3,3),TXR(IDIM,IDIM) REAL*8 D1HO(LHOOK,LHOOK),ROTH(LHOOK,LHOOK) ENDSEGMENT * SEGMENT,MVELCH REAL*8 VALMAT(NV1) ENDSEGMENT * segment mwrk67 real*8 valcar(nca1), xatef1(3,3) endsegment DIMENSION A(4,60),BB(3,60),PP(4,4) CHARACTER*8 CMATE,celem logical drend,BDPGE * * WRITE (*,*) 'Entrée dans RIGI2.' MELEME=IPMAIL NBNN=NUM(/1) NBELEM=NUM(/2) * NV1=NMATT SEGINI,MVELCH * XMATRI=IPMATR c* NLIGRD=LRE c* NLIGRP=LRE C Introduction du point autour duquel se fait le mouvement C de la section en defo plane generalisee C IIPDPG = numero du noeud/point support si defini pour le modele IF (IIPDPG.GT.0) THEN IF (IFOUR.EQ.-3) THEN BDPGE=.TRUE. IREF=(IIPDPG-1)*(IDIM+1) XDPGE=XCOOR(IREF+1) YDPGE=XCOOR(IREF+2) ELSE IF (IFOUR.EQ. 7 .OR. IFOUR.EQ. 8 .OR. IFOUR.EQ. 9 .OR. & IFOUR.EQ.10 .OR. IFOUR.EQ.11 .OR. IFOUR.EQ.14) THEN BDPGE=.TRUE. XDPGE=XZero YDPGE=XZero else write(ioimp,*) 'RIGI2 : ERREUR DPGE' call erreur(5) return ENDIF ELSE BDPGE=.FALSE. XDPGE=XZero YDPGE=XZero ENDIF * NHRM=NIFOUR * MINTE=IPMINT IRTD=1 IDECAP=0 C_______________________________________________________________________ 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_______________________________________________________________________ C IF(MELE.GE.1.AND.MELE.LE.100) THEN C CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8 GOTO ( 99, 99, 99, 4, 99, 4, 99, 4, 99, 4 C QUA9 RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6 1 , 99, 99, 99, 4, 4, 4, 4, 99, 99, 99 C LIA8 MULT TET4 TE10 PYR5 PY13 COQ3 DKT POUT LISP 2 , 99, 99, 4, 4, 4, 4, 99, 99, 99, 99 C FAC3 FAC4 FAC6 FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5 3 , 99, 99, 99, 99, 35, 35, 35, 35, 35, 35 C COQ8 TUYA TUFI COQ2 POI1 BARR RACO LSU2 COQ4 LISM 4 , 99, 99, 99, 99, 99, 99, 99, 48, 99, 99 C COF3 RES2 LSU3 LSU4 LICO COQ6 CVS2 CVS3 CVT3 CVT6 5 , 99, 99, 48, 48, 99, 99, 99, 99, 99, 99 C CVQ4 CVQ8 THP5 TH13 THP6 TH15 THC8 TH20 ICT3 ICQ4 6 , 99, 99, 99, 99, 99, 99, 99, 99, 4, 4 C ICT6 ICQ8 ICC8 ICT4 ICP6 IC20 IC10 IC15 TRIP QUAP 7 , 4, 4, 4, 4, 4, 4, 4, 4, 79, 79 C CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4 JOI6 JOI8 8 , 79, 79, 79, 99, 99, 99, 99, 99, 99, 99 C LISC TRIH DST LIC4 CERC TUYO LSE2 LITU HYT3 HYQ4 9 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99) c cccccc . ,MELE ELSEIF(MELE.GE.101.AND.MELE.LE.200) THEN C HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8 GOTO ( 99, 99, 99, 99, 99, 99, 99, 80, 80, 80 C POL3 POL4 POL5 POL6 POL7 POL8 POL9 PO10 PO11 PO12 1 , 4, 4, 4, 4, 4, 4, 4, 4, 4, 4 C PO13 PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3 2 , 4, 4, 99, 99, 99, 99, 99, 99, 99, 99 C QUF4 CUF8 PRF6 TEF4 PYF5 MSE3 MTR6 MQU9 MC27 MP18 3 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 C MT10 MP14 SEF3 TRF7 QUF9 CF27 PF21 TF15 PF19 SEG6 4 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 C TR21 QU36 C216 P126 TE56 PY91 TRH6 BSE2 BTR4 BQU5 5 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 C BCU9 BPR7 BTE5 BPY6 FRO4 SEGS POJS JCT3 JCI4 JGI2 6 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 C JGT3 JGI4 TRIQ QUAQ CUBQ TETQ PRIQ TRIR QUAR CUBR 7 , 99, 99, 173, 173, 173, 173, 173, 173, 173, 173 C TETR PRIR Q4RI Q8RI JOQ3 JOQ6 JOQ8 JOR3 JOR6 JOR8 8 , 173, 173, 4, 4, 185, 185, 185, 185, 185, 185 C T1D2 T1D3 M1D2 M1D3 LC03 LC07 LC09 LC27 LC21 LC15 9 , 99, 99, 4, 4, 99, 99, 99, 99, 99, 99) c cccccc . ,MELE-100 ELSEIF(MELE.GE.201.AND.MELE.LE.300) THEN C LC19 LS03 LS07 LS09 LS27 LS21 LS15 LS19 BS03 BS07 GOTO ( 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 C BS09 BS27 BS21 BS15 BS19 MC03 MC07 MC09 MC27 MC21 1 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 C MC15 MC19 M103 M107 M109 M127 M121 M115 M119 MS03 2 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 C MS07 MS09 MS27 MS21 MS15 MS19 QC03 QC07 QC09 QC27 3 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 C QC21 QC15 QC19 Q103 Q107 Q109 Q127 Q121 Q115 Q119 4 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 C QS03 QS07 QS09 QS27 QS21 QS15 QS19 CIFL SURE SHB8 5 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 C CAF2 CAF3 XQ4R XC8R JOI1 ZCO2 ZCO3 ZCO4 TUY2 TUY3 6 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 C COS2 COA2 ICY5 IC13 CU27 PR21 TE15 PY19 C20R P15R 7 , 99, 99, 4, 4, 4, 4, 4, 4, 4, 4) c cccccc . ,MELE-200 ENDIF GOTO 99 C_______________________________________________________________________ C C SECTEUR DE CALCUL POUR LES ELEMENTS MASSIFS ET INCOMPRESSIBLES C_______________________________________________________________________ C 4 CONTINUE DIM3=1.D0 * * CAS ORTHOTROPE ( 2) ANISOTROPE ( 3) UNIDIRICTIONNEL (4) * * RECUPERATION DES FONCTIONS DE FORME ET LEURS DERIVEES AU CENTRE DE * L'ELEMENT POUR LE CALCUL DES AXES LOCAUX IPMIN2 = 0 IF ( (MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) .AND. IMAT.EQ.1) THEN NLG=NUMGEO(MELE) CALL RESHPT(1,NBNN,NLG,MELE,0,IPMIN2,IRT1) MINTE2=IPMIN2 SEGACT MINTE2 SEGINI WRK8 ENDIF NBNO=NBNN NBBB=NBNN SEGINI WRK1,WRK2 if (melpha.gt.0) melva1 = melpha * Initialisation en cas de matrice d'efficacite MWRK67 = 0 celem = ' ' IF (IVACAR.GT.0) THEN MPTVAL=IVACAR * SEGACT,MPTVAL IF (IVAL(NCAR1).GT.0 .OR. IVAL(NCAR1+1).GT.0) THEN nca1 = IVAL(/1) SEGINI,MWRK67 celem = 'MASSIF ' nstep = 2 if (ifour.eq.2) nstep = 3 drend = .false. irend = 0 if (ival(ncar1).gt.0.and.tyval(ncar1).eq.'REAL*8') then drend = .true. irend = 1 endif if (ival(ncar1).eq.0.and.tyval(ncar1+1).eq.'REAL*8') then drend = .false. irend = 2 endif ENDIF ENDIF DO 3004 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 CALCUL DES AXES LOCAUX DANS LE CAS DES MATERIAUX ORTHOTROPE , C ANISOTROPE ET UNIDIRECTIONNEL C C* IF((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4).AND.IMAT.EQ.1)THEN IF (IPMIN2.NE.0) THEN NBSH=MINTE2.SHPTOT(/2) CALL RLOCAL (XE,MINTE2.SHPTOT,NBSH,NBNN,TXR) if (nbsh.eq.-1) then call erreur(525) goto 9904 endif ENDIF C CALL ZERO (RINT,LRE,LRE) C C= EF InCompressibles : CALCUL DES COEFF UTILES A LA MATRICE B-BARRE IF (MFR.EQ.31) THEN CALL BBCALC(MELE,NBNN,MFR,IDIM,XE, & NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU, & NSTRS,LRE,IFOUR,NHRM,A,BB,SHPTOT,SHPWRK, & BGENE,XDPGE,YDPGE,PP,NOER) IF (NOER.NE.0) THEN CALL ERREUR(noer) RETURN ENDIF ENDIF C segact,wrk1*mod C C BOUCLE SUR LES POINTS DE GAUSS C ISDJC=0 DO 4004 IGAU=1,NBPGAU C C RECUPERATION DE L'EPAISSEUR C IF (IFOUR.EQ.-2)THEN MPTVAL=IVACAR IF (IVACAR.NE.0) THEN MELVAL=IVAL(1) IF (MELVAL.NE.0) THEN IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) DIM3=VELCHE(IGMN,IBMN) ELSE DIM3=1.D0 ENDIF ENDIF ENDIF * CALL BMATST(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU, 1 MELE,MFR,NBNN,LRE,IFOUR,NSTRS,NHRM,DIM3,XE, 2 SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE) IF (DJAC.EQ.0.D0) THEN INTERR(1)=IB CALL ERREUR(259) GOTO 9904 ENDIF IF (DJAC.LT.0.D0) ISDJC=ISDJC+1 DJAC=ABS(DJAC)*POIGAU(IGAU) C En cas d'elements incompressibles : BGENE selon la methode B-BARRE IF (MFR.EQ.31) THEN CALL BBAR(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU, & MELE,NBNN,LRE,IFOUR,NSTRS,XE,DJAC,A,BB,BGENE) ENDIF C MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) IGMN=MIN(IGAU,IELCHE(/1)) MLREEL=IELCHE(IGMN,IBMN) SEGACT,MLREEL CALL DOHOOO(PROG,LHOOK,DDHOOK) C SEGDES MLREEL ENDIF ELSE IF (IMAT.EQ.1) THEN DO 9004 IM=1,NMATT IF (IVAL(IM).NE.0) THEN MELVAL=IVAL(IM) IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) if (ibmn.gt.0.and.igmn.gt.0) then VALMAT(IM)=VELCHE(IGMN,IBMN) else VALMAT(IM)=0.D0 endif ELSE VALMAT(IM)=0.D0 ENDIF 9004 CONTINUE IF(MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4)THEN IF(IGAU.LE.NBGMAT) 1 CALL DOHMAO(VALMAT,CMATE,IFOUR,IDIM,TXR,XLOC,XGLOB,D1HO, 2 ROTH,DDHOOK,LHOOK,1,IRTD) ELSE IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOHMAS(VALMAT,CMATE,IFOUR,LHOOK,1,DDHOOK,IRTD) ENDIF ENDIF C C CHOIX POUR BDB/DEFO PLANE GENE --- PRODUIT MATRICIEL NORMAL C /MASSIF ------------ PRODUIT PAR BLOC C * initialise CALL ZERO (REL,LRE,LRE) * calcul rigidite elementaire IF (BDPGE) THEN CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL) ELSE CALL BDBS1(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL,MFR,IFOUR,MATE, 1 IGAU,IMAT,0.D0) ENDIF * matrice d'efficacite IF (MWRK67.GT.0) THEN MPTVAL=IVACAR DO 9008 IM= 1,IVAL(/1) IF (IVAL(IM).GT.0) THEN MELVAL=IVAL(IM) IF (TYVAL(IM).EQ.'REAL*8') THEN IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) VALCAR(IM)=VELCHE(IGMN,IBMN) ELSE IBMN=MIN(IB ,IELCHE(/2)) IGMN=MIN(IGAU,IELCHE(/1)) VALCAR(IM)=IELCHE(IGMN,IBMN) ENDIF ELSE VALCAR(IM)=0.D0 ENDIF 9008 CONTINUE do i = 1,nstep do j = 1, nstep xatef1(i,j) = 0.d0 enddo enddo if (irend.eq.1) then xatef1(1,1) = valcar(ncar1) xatef1(2,2) = valcar(ncar1) if (nstep.eq.3) xatef1(3,3) = valcar(ncar1) else if (irend.eq.2) then xatef1(1,1) = valcar(ncar1+7) xatef1(2,2) = valcar(ncar1+8) if (nstep.eq.3) xatef1(3,3) = valcar(ncar1+9) endif call effi2(valcar,tyval,nca1,ncar1,rel,lre,ib,igau,xatef1, & nstep,drend,celem) ENDIF * ponderation par la phase IF (MELPHA.GT.0) THEN IBMN=MIN(IB ,melva1.VELCHE(/2)) IGMN=MIN(IGAU,melva1.VELCHE(/1)) coe1 = melva1.velche(igmn,ibmn) ELSE coe1 = 1.D0 ENDIF * stocke do jj = 1,LRE do ii = 1,LRE rint(ii,jj) = rint(ii,jj) + rel(ii,jj)*coe1 enddo enddo * 4004 CONTINUE * IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN INTERR(1)=IB if (noer.eq.0) CALL ERREUR(195) noer=195 GOTO 9904 ENDIF C C REMPLISSAGE DE XMATRI C c CALL REMPMT(RINT,LRE,RE) DO IBK=1,LRE DO IAK=1,LRE RE(IAK,IBK,IB)=RINT(IAK,IBK) ENDDO ENDDO * do i = 1,8 * write(6,*) re(13,3*i-2),re(13,3*i-1),re(13,3*i) * enddo * 3004 CONTINUE c IF(IRTD.EQ.0) THEN MOTERR(1:8)=CMATE MOTERR(9:16)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF 9904 CONTINUE C* IF ((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) .AND.IMAT.EQ.1) THEN IF (IPMIN2.NE.0) THEN SEGDES MINTE2 SEGSUP WRK8 ENDIF SEGSUP WRK1,WRK2 IF (MWRK67.NE.0) SEGSUP,MWRK67 GOTO 510 C_______________________________________________________________________ C C SECTEUR DE CALCUL POUR LES ELEMENTS LIQUIDES C_______________________________________________________________________ C 35 CONTINUE NBNO=NBNN NBBB=NBNN NSTRS=NDDL SEGINI WRK1,WRK2 c DO 3035 IB=1,NBELEM C C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) CALL ZERO (REL,LRE,LRE) C C BOUCLE SUR LES POINTS DE GAUSS C ISDJC=0 DO 4035 IGAU=1,NBPGAU MPTVAL=IVAMAT DO IM=1,5 IF (IVAL(IM).NE.0) THEN MELVAL=IVAL(IM) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) VALMAT(IM)=VELCHE(IGMN,IBMN) ELSE VALMAT(IM)=0.D0 ENDIF ENDDO C C CALCUL DES COEFFICIENTS DE NORMALISATION C RHO =VALMAT(1) C =VALMAT(2) RHOREF=VALMAT(3) CREF =VALMAT(4) RLCAR =VALMAT(5) C COEFPR=(RHOREF*CREF*CREF)/RLCAR VKL =(COEFPR*COEFPR)/(RHO*C*C) CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NSTRS,1.D0,XE, 1 SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE) IF(DJAC.LT.0.D0) ISDJC=ISDJC+1 DJAC=ABS(DJAC)*POIGAU(IGAU) CALL NKLNST(BGENE,DJAC,VKL,LRE,NSTRS,REL) 4035 CONTINUE * IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN INTERR(1)=IB CALL ERREUR(195) noer=195 GOTO 9935 ENDIF C C REMPLISSAGE DE XMATRI C CALL REMPMT(REL,LRE,RE(1,1,IB)) 3035 CONTINUE * 9935 CONTINUE SEGSUP WRK1,WRK2 GOTO 510 C_______________________________________________________________________ C C SECTEUR DE CALCUL POUR LES ELEMENTS DE SURFACE LIBRE C_______________________________________________________________________ C 48 CONTINUE NBNO=NBNN NBBB=NBNN NSTRS=NDDL SEGINI WRK1,WRK2 c DO 3048 IB=1,NBELEM C C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) CALL ZERO (REL,LRE,LRE) C MPTVAL=IVAMAT DO 9048 IM=1,6 IF (IVAL(IM).NE.0) THEN MELVAL=IVAL(IM) IBMN=MIN(IB ,VELCHE(/2)) VALMAT(IM)=VELCHE(1,IBMN) ELSE VALMAT(IM)=0.D0 ENDIF 9048 CONTINUE C RHO =VALMAT(1) G =VALMAT(6) VKS =RHO*G C C BOUCLE SUR LES POINTS DE GAUSS C ISDJC=0 DO 4048 IGAU=1,NBPGAU CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NSTRS,1.D0,XE, 1 SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE) IF(DJAC.LT.0.0) ISDJC=ISDJC+1 DJAC=ABS(DJAC)*POIGAU(IGAU) CALL NKSNST(BGENE,DJAC,VKS,LRE,NSTRS,REL) 4048 CONTINUE IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN INTERR(1)=IB CALL ERREUR(195) noer=195 GOTO 9948 ENDIF C C REMPLISSAGE DE XMATRI C CALL REMPMT(REL,LRE,RE(1,1,ib)) 3048 CONTINUE C 9948 CONTINUE SEGSUP WRK1,WRK2 GOTO 510 C_______________________________________________________________________ C C MILIEUX POREUX C_______________________________________________________________________ C 79 CONTINUE C C* Cas non pevus actuellement IF (IMAT.EQ.1) THEN IF (MATE.LT.1.OR.MATE.GT.4) GOTO 99 ELSE GOTO 99 ENDIF C C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS C NBNO = NOMBRE DE FONCTIONS DE FORME C ON ENLEVE LA PRESSION POREUSE DES CONTRAINTES C DIM3=1.D0 NCOT=0 NBNO=IPORE NBBB=NBNN NSTN=1 **************** AM 08/01/01 ***** NSTMU=2 ***** IF(IFOUR.GE.0) NSTMU=3 NSTMU=3 LRN = NBNO-NBBB LRB=LRE-NBNN IELE=NUMGEO(MELE) IF(IELE.EQ.6 ) NCOT=3 IF(IELE.EQ.10) NCOT=4 IF(IELE.EQ.15) NCOT=12 IF(IELE.EQ.17) NCOT=9 IF(IELE.EQ.24) NCOT=6 IF(NCOT.EQ.0) THEN CALL ERREUR(5) GOTO 510 ENDIF * * CAS NON ISOTROPES * RECUPERATION DES FONCTIONS DE FORME ET LEURS DERIVEES * AU CENTRE DE L'ELEMENT POUR LE CALCUL DES AXES LOCAUX * IPMIN2 = 0 IF ( (MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4).AND.IMAT.EQ.1 ) THEN CALL RESHPT(1,NBNO,IELE,MELE,0,IPMIN2,IRT1) MINTE2=IPMIN2 SEGACT MINTE2 SEGINI WRK8 NSTMU=LHOOK ENDIF * SEGINI WRK1,WRK2,WRK5,WRK55 * DO 3079 IB=1,NBELEM * * ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB * CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) * * CALCUL DES AXES LOCAUX DANS LES CAS NON ISOTROPES * C* IF((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) C* . .AND.IMAT.EQ.1)THEN IF (IPMIN2.NE.0) THEN NBSH=MINTE2.SHPTOT(/2) CALL RLOCAL (XE,MINTE2.SHPTOT,NBSH,NBNN,TXR) if (nbsh.eq.-1) then call erreur(525) goto 9979 endif ENDIF * CALL ZERO (REL,LRE,LRE) * * TRAITEMENT POUR NOEUDS MILIEUX PRESSION * FREF = 1.D6 CALL BNPOR2(YGENE,NCOT,IELE) IF(IERR.NE.0) GOTO 9979 * * DO 27895 IOI=1,NCOT * WRITE(6,28927) IOI *28927 FORMAT(2X,' MATRICE YGENE - LIGNE ',I3) * WRITE(6,28928) (YGENE(IOI,J),J=1,NBNN) *28928 FORMAT(8(1X,1PE10.3)) *27895 CONTINUE C C BOUCLE SUR LES POINTS DE GAUSS C ISDJC=0 DO 4079 IGAU=1,NBPGAU C C RECUPERATION DE L'EPAISSEUR C IF (IFOUR.EQ.-2)THEN MPTVAL=IVACAR IF (IVACAR.NE.0) THEN MELVAL=IVAL(1) IF (MELVAL.NE.0) THEN IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) DIM3=VELCHE(IGMN,IBMN) ELSE DIM3=1.D0 ENDIF ENDIF ENDIF C c write(6,*) 'rigi2 WRK1,lhook,nstrs=',WRK1,lhook,nstrs CALL BNPORE(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,NHRM, . DIM3,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,1) IF (DJAC.EQ.0.D0) THEN INTERR(1)=IB CALL ERREUR(259) GOTO 9979 ENDIF IF (DJAC.LT.0.D0) ISDJC=ISDJC+1 DJAC=ABS(DJAC)*POIGAU(IGAU) C * IF(IGAU.EQ.1) THEN * DO 27892 IOI=1,LHOOK * WRITE(6,28920) IOI *28920 FORMAT(2X,' MATRICE BGENE - LIGNE ',I3) * WRITE(6,28921) (BGENE(IOI,J),J=1,LRE) *28921 FORMAT(8(1X,1PE10.3)) *27892 CONTINUE * DO 27893 IOI=1,NSTN * WRITE(6,28922) IOI *28922 FORMAT(2X,' MATRICE XGENE - LIGNE ',I3) * WRITE(6,28923) (XGENE(IOI,J),J=1,LRN) *28923 FORMAT(8(1X,1PE10.3)) *27893 CONTINUE * ENDIF MPTVAL=IVAMAT C*D IF(IMAT.EQ.2) THEN C*D GO TO 99 C*D ELSE IF (IMAT.EQ.1) THEN * DO 9079 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 9079 CONTINUE * IF(MATE.EQ.1) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) . CALL DOHMAS(VALMAT,CMATE,IFOUR,LHOOK,1,DDHOOK,IRTD) DO 4879 I=1,NSTMU COBMA(I) =VALMAT(3) 4879 CONTINUE XMOB =VALMAT(4) * ELSE IF(MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN IF(IGAU.LE.NBGMAT) . CALL PORMAO(VALMAT,CMATE,IFOUR,IDIM,TXR,XLOC,XGLOB,D1HO, . ROTH,DDHOOK,LHOOK,COBMA,XMOB,1,IRTD) C*D ELSE C*D GO TO 99 ENDIF * C*D ENDIF * CALL BDBS1(BGENE,DJAC,DDHOOK,LRE,LHOOK,REL,MFR,IFOUR,MATE, . IGAU,IMAT,0.D0) EREF =1.D0 DJACER=DJAC*EREF DO I=1,LRB DO J=1,LRN JJ=J+LRB r_z = 0.D0 DO K=1,NSTMU r_z = r_z + COBMA(K)*BGENE(K,I) ENDDO r_z = r_z * DJACER * XGENE(1,J) REL(JJ,I)=REL(JJ,I) - r_z ENDDO ENDDO * IF(XMOB.EQ.0.D0) THEN UNSURM=0.D0 ELSE UNSURM=1.D0 / XMOB ENDIF COMJAC=UNSURM*DJAC*EREF*EREF DO I=1,LRN II=I+LRB r_z = COMJAC*XGENE(1,I) DO J=1,I JJ=J+LRB REL(II,JJ)=REL(II,JJ)-r_z*XGENE(1,J) ENDDO ENDDO C COMJAC=UNSURM*DJAC*FREF DO I=1,NBNN II=I+LRB DO J=1,I JJ=J+LRB r_z = 0.D0 DO K=1,NCOT r_z = r_z + YGENE(K,I)*YGENE(K,J) ENDDO REL(II,JJ)=REL(II,JJ) + (COMJAC*r_z) ENDDO ENDDO * 4079 CONTINUE IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN INTERR(1)=IB CALL ERREUR(195) noer=195 GOTO 9979 ENDIF C C REMPLISSAGE DE XMATRI C CALL REMPMT(REL,LRE,RE(1,1,ib)) * 3079 CONTINUE c IF(IRTD.EQ.0) THEN MOTERR(1:8)=CMATE MOTERR(9:16)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF 9979 CONTINUE SEGSUP WRK1,WRK2,WRK5,WRK55 C* IF ((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4).AND.IMAT.EQ.1) THEN IF (IPMIN2.NE.0) THEN SEGDES MINTE2 SEGSUP WRK8 ENDIF GOTO 510 C_______________________________________________________________________ C C MILIEUX POREUX - SUITE C_______________________________________________________________________ C 173 CONTINUE C C CAS NON ISOTROPES NON PREVUS ACTUELLEMENT IF (IMAT.EQ.1) THEN IF (MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN CALL ERREUR(251) GO TO 510 ENDIF ELSE C* ELSE IF (IMAT.EQ.2) THEN GO TO 99 ENDIF C C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS C NBNO = NOMBRE DE FONCTIONS DE FORME C ON ENLEVE LA PRESSION POREUSE DES CONTRAINTES C IF(MFR.EQ.57) IDECAP=2 IF(MFR.EQ.59) IDECAP=3 * DIM3=1.D0 NCOT=0 NBNO=IPORE NBBB=NBNN NSTN=IDECAP * **************** AM 08/01/01 ***** NSTMU=2 ***** IF(IFOUR.GE.0) NSTMU=3 * NSTMU=3 LPP=NBNO-NBBB LRN = IDECAP*LPP **** LRB=LRE-LRN LRB=LRE-(IDECAP*NBBB) IELE=NUMGEO(MELE) * IF(IELE.EQ.6 ) NCOT=3 IF(IELE.EQ.10) NCOT=4 IF(IELE.EQ.15) NCOT=12 IF(IELE.EQ.17) NCOT=9 IF(IELE.EQ.24) NCOT=6 IF(NCOT.EQ.0) THEN CALL ERREUR(5) GO TO 510 ENDIF * SEGINI WRK1,WRK2,WRK5,WRK55,WRK555 DO 3173 IB=1,NBELEM * * ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB * CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) * CALL ZERO (REL,LRE,LRE) * * TRAITEMENT POUR NOEUDS MILIEUX PRESSION * FREF = 1.D6 CALL BNPOR2(YGENE,NCOT,IELE) IF(IERR.NE.0) GO TO 9973 * DO 17895 IOI=1,NCOT * WRITE(6,78927) IOI *78927 FORMAT(2X,' MATRICE YGENE - LIGNE ',I3) * WRITE(6,78928) (YGENE(IOI,J),J=1,NBNN) *78928 FORMAT(8(1X,1PE10.3)) *17895 CONTINUE C C BOUCLE SUR LES POINTS DE GAUSS C ISDJC=0 DO 4173 IGAU=1,NBPGAU C C RECUPERATION DE L'EPAISSEUR C IF (IFOUR.EQ.-2)THEN MPTVAL=IVACAR IF (IVACAR.NE.0) THEN MELVAL=IVAL(1) IF (MELVAL.NE.0) THEN IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) DIM3=VELCHE(IGMN,IBMN) ELSE DIM3=1.D0 ENDIF ENDIF ENDIF C NSTB=LHOOK CALL BNQORE(IGAU,NBNO,NBBB,LRE,IFOUR,NSTB,NSTN,NHRM, . DIM3,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,IDECAP,LHOOK,1) IF(DJAC.EQ.0.D0) THEN INTERR(1)=IB CALL ERREUR(259) GOTO 9973 ENDIF IF(DJAC.LT.0.D0) ISDJC=ISDJC+1 DJAC=ABS(DJAC)*POIGAU(IGAU) C * IF(IGAU.EQ.1) THEN * DO 17892 IOI=1,LHOOK * WRITE(6,78920) IOI *78920 FORMAT(2X,' MATRICE BGENE - LIGNE ',I3) * WRITE(6,78921) (BGENE(IOI,J),J=1,LRE) *78921 FORMAT(8(1X,1PE10.3)) *17892 CONTINUE * DO 17893 IOI=1,NSTN * WRITE(6,78922) IOI *78922 FORMAT(2X,' MATRICE XGENE - LIGNE ',I3) * WRITE(6,78923) (XGENE(IOI,J),J=1,LRN) *78923 FORMAT(8(1X,1PE10.3)) *17893 CONTINUE * ENDIF MPTVAL=IVAMAT C*D IF(IMAT.EQ.2) THEN C*D GO TO 99 C*D ELSE IF (IMAT.EQ.1) THEN * DO 9173 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 9173 CONTINUE * C*D IF(MATE.EQ.1) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) . CALL DOHMAS(VALMAT,CMATE,IFOUR,LHOOK,1,DDHOOK,IRTD) * C*D ELSE C*D GO TO 99 C*D ENDIF C*D ENDIF * CALL BDBSTS(BGENE,DJAC,DDHOOK,LRE,LHOOK,REL) EREF =1.D0 * IF(MFR.EQ.57) THEN COBB(1) = VALMAT(3) COBB(2) = VALMAT(4) CPBB(1) = VALMAT(5) CPBB(2) = VALMAT(6) KKBB(1,1)= VALMAT(7) KKBB(1,2)= VALMAT(8) KKBB(2,1)= VALMAT(9) KKBB(2,2)= VALMAT(10) * ELSE IF(MFR.EQ.59) THEN COBB(1) = VALMAT(3) COBB(2) = VALMAT(4) COBB(3) = VALMAT(5) CPBB(1) = VALMAT(6) CPBB(2) = VALMAT(7) CPBB(3) = VALMAT(8) KKBB(1,1)= VALMAT(9) KKBB(1,2)= VALMAT(10) KKBB(1,3)= VALMAT(11) KKBB(2,1)= VALMAT(12) KKBB(2,2)= VALMAT(13) KKBB(2,3)= VALMAT(14) KKBB(3,1)= VALMAT(15) KKBB(3,2)= VALMAT(16) KKBB(3,3)= VALMAT(17) ENDIF * DJACER=DJAC*EREF DO IPR=1,IDECAP LRBDEC=LRB + (IPR-1)*NBBB LPPDEC= (IPR-1)*LPP COMJAC=COBB(IPR)*DJACER DO I=1,LRB r_z = 0.D0 DO K=1,NSTMU r_z = r_z + BGENE(K,I) ENDDO r_z = r_z * COMJAC DO J=1,LPP JJ=J+LRBDEC JX=J+LPPDEC REL(I,JJ)=REL(I,JJ)-r_z*XGENE(IPR,JX) ENDDO ENDDO ENDDO * DO IPR=1,IDECAP LRBDEC=LRB + (IPR-1)*NBBB LPPDEC= (IPR-1)*LPP COMJAC=CPBB(IPR)*DJACER DO I=1,LRB r_z = 0.D0 DO K=1,NSTMU r_z = r_z + BGENE(K,I) ENDDO r_z = COMJAC*r_z DO J=1,LPP JJ=J+LRBDEC JX=J+LPPDEC * ici - pour bsig REL(JJ,I)=REL(JJ,I)-r_z*XGENE(IPR,JX) ENDDO ENDDO ENDDO * COMJAC=DJAC*EREF*EREF CALL ZERO(XREL,LRN,LRN) CALL BDBSTS(XGENE,COMJAC,KKBB,LRN,NSTN,XREL) DO IPR=1,IDECAP IRBDEC=LRB + (IPR-1)*NBBB IPPDEC= (IPR-1)*LPP DO JPR=1,IDECAP JRBDEC=LRB + (JPR-1)*NBBB JPPDEC= (JPR-1)*LPP DO I=1,LPP II=I+IRBDEC IX=I+IPPDEC DO J=1,LPP JJ=J+JRBDEC JX=J+JPPDEC * IF(IGAU.EQ.1) THEN * PRINT *,'I =',I,' IX=',IX,' II=',II * PRINT *,'J =',J,' JX=',JX,' JJ=',JJ, ' XREL=',XREL(IX,JX) * ENDIF REL(II,JJ)=REL(II,JJ)-XREL(IX,JX) ENDDO ENDDO ENDDO ENDDO C DO IPR=1,IDECAP COMJAC=KKBB(IPR,IPR)*DJAC*FREF LRBDEC=LRB + (IPR-1)*NBBB DO I=1,NBNN II=I+LRBDEC DO J=1,NBNN JJ=J+LRBDEC r_z = 0.D0 DO K=1,NCOT r_z = r_z + YGENE(K,I)*YGENE(K,J) ENDDO REL(II,JJ)=REL(II,JJ) + (COMJAC * r_z) ENDDO ENDDO ENDDO * 4173 CONTINUE IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN INTERR(1)=IB CALL ERREUR(195) noer=195 GOTO 9973 ENDIF C C REMPLISSAGE DE XMATRI C CALL REMPMS(REL,LRE,RE(1,1,ib)) 3173 CONTINUE c IF(IRTD.EQ.0) THEN MOTERR(1:8)=CMATE MOTERR(9:16)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF 9973 CONTINUE SEGSUP WRK1,WRK2,WRK5,WRK55,WRK555 GOTO 510 C_______________________________________________________________________ C C JOINTS EN FORMULATION MILIEUX POREUX C_______________________________________________________________________ C 80 CONTINUE C * CAS NON PREVUS IF (IMAT.EQ.1) THEN IF (MATE.NE.1) GOTO 99 ELSE IF (IMAT.EQ.2) THEN GOTO 99 ENDIF C C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS C NBNO = NOMBRE DE FONCTIONS DE FORME C ON ENLEVE LA PRESSION POREUSE DES CONTRAINTES C NCOT=0 NBNO=IPORE NBBB=NBNN NSTN=1 NSTMU=2 IF(IFOUR.EQ.2) NSTMU=3 LRN=(NBNO-NBBB)*3/2 LPP=LRN LRB=LRE-NBNN IELE=NUMGEO(MELE) IF(IELE.EQ.29) NCOT=2 IF(IELE.EQ.30) NCOT=6 IF(IELE.EQ.31) NCOT=8 IF(NCOT.EQ.0) THEN CALL ERREUR(5) GO TO 510 ENDIF * SEGINI WRK1,WRK2,WRK3,WRK5,WRK55 * DO 3080 IB=1,NBELEM * * ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB * CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) * * CALCUL DES AXES LOCAUX ET DES COORDONNES LOCALES * CALL JOPLOC(XE,SHPTOT,NBBB,NBNO,IFOUR,XEL,BPSS) * CALL ZERO (REL,LRE,LRE) * CALL INTDEL(XNTH,XNTB,XNTT,LRN,MELE) * * TRAITEMENT POUR NOEUDS MILIEUX PRESSION * FREF = 1.D6 CALL BNPOR2(YGENE,NCOT,IELE) IF (IERR.NE.0) GOTO 9980 * * BOUCLE SUR LES POINTS DE GAUSS * ISDJC=0 DO 4080 IGAU=1,NBPGAU * CALL BNPORJ(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,XE,XEL, . SHPTOT,SHPWRK,BPSS,BGENE,XGENE,DJAC,1) IF (DJAC.EQ.0.D0) THEN INTERR(1)=IB CALL ERREUR(259) GOTO 9980 ENDIF IF(DJAC.LT.0.D0) ISDJC=ISDJC+1 DJAC=ABS(DJAC)*POIGAU(IGAU) * MPTVAL=IVAMAT C*D IF(IMAT.EQ.2) THEN C*D GO TO 99 C*D ELSE IF (IMAT.EQ.1) THEN * DO 9080 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 9080 CONTINUE * C*D IF(MATE.EQ.1) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) . CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) C*D ELSE C*D GO TO 99 C*D ENDIF C*D ENDIF * CALL BDBS1(BGENE,DJAC,DDHOOK,LRE,LHOOK,REL,MFR,IFOUR,MATE, . IGAU,IMAT,0.D0) EREF =1.D0 * COBMA(NSTMU)=VALMAT(3) XMOB=VALMAT(4) * IF(XMOB.EQ.0.D0) THEN UNSURM=0.D0 ELSE UNSURM=1.D0 / XMOB ENDIF * DJACER=DJAC*EREF*COBMA(NSTMU) DO I=1,LRB r_z = DJACER*BGENE(NSTMU,I) DO J=1,LRN JJ=J+LRB REL(JJ,I)=REL(JJ,I)-r_z*XGENE(1,J)*XNTT(J) ENDDO ENDDO * COMJAC=UNSURM*DJAC*EREF*EREF DO I=1,LRN II=I+LRB r_z = COMJAC*XGENE(1,I)*XNTT(I) DO J=1,I JJ=J+LRB REL(II,JJ)=REL(II,JJ)-r_z*XGENE(1,J)*XNTT(J) ENDDO ENDDO * COMJAC=UNSURM*DJAC*FREF DO I=1,NBNN II=I+LRB DO J=1,I JJ=J+LRB r_z = 0.D0 DO K=1,NCOT r_z = r_z + YGENE(K,I)*YGENE(K,J) ENDDO REL(II,JJ)=REL(II,JJ)+COMJAC*r_z ENDDO ENDDO * 4080 CONTINUE IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN INTERR(1)=IB CALL ERREUR(195) noer=195 GOTO 9980 ENDIF * * REMPLISSAGE DE XMATRI * CALL REMPMT(REL,LRE,RE(1,1,IB)) 3080 CONTINUE IF(IRTD.EQ.0) THEN MOTERR(1:8)=CMATE MOTERR(9:16)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF 9980 CONTINUE SEGSUP WRK1,WRK2,WRK3,WRK5,WRK55 GOTO 510 * C_______________________________________________________________________ C C JOINTS EN FORMULATION MILIEUX POREUX - SUITE C_______________________________________________________________________ C 185 CONTINUE C * CAS NON ISOTROPES NON PREVUS ACTUELLEMENT IF (IMAT.EQ.1) THEN IF (MATE.NE.1) GOTO 99 ELSE GOTO 99 ENDIF C C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS C NBNO = NOMBRE DE FONCTIONS DE FORME C ON ENLEVE LA PRESSION POREUSE DES CONTRAINTES C IF(MFR.EQ.57) IDECAP=2 IF(MFR.EQ.59) IDECAP=3 * NCOT=0 NBNO=IPORE NBBB=NBNN NSTN=IDECAP NSTMU=2 IF(IFOUR.EQ.2) NSTMU=3 LPP=(NBNO-NBBB)*3/2 LRN=IDECAP*LPP LRB=LRE-IDECAP*NBNN IELE=NUMGEO(MELE) IF(IELE.EQ.29) NCOT=2 IF(IELE.EQ.30) NCOT=6 IF(IELE.EQ.31) NCOT=8 IF(NCOT.EQ.0) THEN CALL ERREUR(5) GO TO 510 ENDIF * SEGINI WRK1,WRK2,WRK3,WRK5,WRK55,WRK555 * DO 3185 IB=1,NBELEM * * ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB * CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) * * CALCUL DES AXES LOCAUX ET DES COORDONNES LOCALES * CALL JOPLOC(XE,SHPTOT,NBBB,NBNO,IFOUR,XEL,BPSS) * CALL ZERO (REL,LRE,LRE) * CALL INTDEL(XNTH,XNTB,XNTT,LPP,MELE) * * TRAITEMENT POUR NOEUDS MILIEUX PRESSION * FREF = 1.D6 CALL BNPOR2(YGENE,NCOT,IELE) IF (IERR.NE.0) GOTO 9985 * * BOUCLE SUR LES POINTS DE GAUSS * ISDJC=0 DO 4185 IGAU=1,NBPGAU * NSTB=LHOOK CALL BNPQRJ(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,XE,XEL, . SHPTOT,SHPWRK,BPSS,BGENE,XGENE,DJAC,IDECAP,NSTB,1) IF (DJAC.EQ.0.D0) THEN INTERR(1)=IB CALL ERREUR(259) GOTO 9985 ENDIF IF(DJAC.LT.0.D0) ISDJC=ISDJC+1 DJAC=ABS(DJAC)*POIGAU(IGAU) * MPTVAL=IVAMAT C*D IF(IMAT.EQ.2) THEN C*D GO TO 99 C*D ELSE IF (IMAT.EQ.1) THEN * DO 9185 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 9185 CONTINUE * C*D IF(MATE.EQ.1) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) . CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) C*D ELSE C*D GO TO 99 C*D ENDIF C*D ENDIF * CALL BDBSTS(BGENE,DJAC,DDHOOK,LRE,LHOOK,REL) EREF =1.D0 * IF(MFR.EQ.57) THEN COBB(1) = VALMAT(3) COBB(2) = VALMAT(4) CPBB(1) = VALMAT(5) CPBB(2) = VALMAT(6) KKBB(1,1)= VALMAT(7) KKBB(1,2)= VALMAT(8) KKBB(2,1)= VALMAT(9) KKBB(2,2)= VALMAT(10) * ELSE IF(MFR.EQ.59) THEN COBB(1) = VALMAT(3) COBB(2) = VALMAT(4) COBB(3) = VALMAT(5) CPBB(1) = VALMAT(6) CPBB(2) = VALMAT(7) CPBB(3) = VALMAT(8) KKBB(1,1)= VALMAT(9) KKBB(1,2)= VALMAT(10) KKBB(1,3)= VALMAT(11) KKBB(2,1)= VALMAT(12) KKBB(2,2)= VALMAT(13) KKBB(2,3)= VALMAT(14) KKBB(3,1)= VALMAT(15) KKBB(3,2)= VALMAT(16) KKBB(3,3)= VALMAT(17) ENDIF * DO IPR=1,IDECAP LPPDEC= (IPR-1)*LPP DO J=1,LPP JX=J+LPPDEC XGENE(IPR,JX)= XGENE(IPR,JX)*XNTT(J) ENDDO ENDDO * DJACER=DJAC*EREF DO IPR=1,IDECAP LRBDEC=LRB + (IPR-1)*NBBB LPPDEC= (IPR-1)*LPP COMJAC=COBB(IPR)*DJACER DO I=1,LRB r_z = COMJAC*BGENE(NSTMU,I) DO J=1,LPP JJ=J+LRBDEC JX=J+LPPDEC REL(I,JJ)=REL(I,JJ)-r_z*XGENE(IPR,JX) ENDDO ENDDO ENDDO * DO IPR=1,IDECAP LRBDEC=LRB + (IPR-1)*NBBB LPPDEC= (IPR-1)*LPP COMJAC=CPBB(IPR)*DJACER DO I=1,LRB r_z = COMJAC*BGENE(NSTMU,I) DO J=1,LPP JJ=J+LRBDEC JX=J+LPPDEC REL(JJ,I)=REL(JJ,I)-r_z*XGENE(IPR,JX) ENDDO ENDDO ENDDO * COMJAC=DJAC*EREF*EREF CALL ZERO(XREL,LRN,LRN) CALL BDBSTS(XGENE,COMJAC,KKBB,LRN,NSTN,XREL) DO IPR=1,IDECAP IRBDEC=LRB + (IPR-1)*NBBB IPPDEC= (IPR-1)*LPP DO JPR=1,IDECAP JRBDEC=LRB + (JPR-1)*NBBB JPPDEC= (JPR-1)*LPP DO I=1,LPP II=I+IRBDEC IX=I+IPPDEC DO J=1,LPP JJ=J+JRBDEC JX=J+JPPDEC * IF(IGAU.EQ.1) THEN * PRINT *,'I =',I,' IX=',IX,' II=',II * PRINT *,'J =',J,' JX=',JX,' JJ=',JJ, ' XREL=',XREL(IX,JX) * ENDIF REL(II,JJ)=REL(II,JJ)-XREL(IX,JX) ENDDO ENDDO ENDDO ENDDO * DO IPR=1,IDECAP COMJAC=KKBB(IPR,IPR)*DJAC*FREF LRBDEC=LRB + (IPR-1)*NBBB DO I=1,NBNN II=I+LRBDEC DO J=1,NBNN JJ=J+LRBDEC r_z = 0.D0 DO K=1,NCOT r_z = r_z + YGENE(K,I)*YGENE(K,J) ENDDO REL(II,JJ)=REL(II,JJ)+COMJAC*r_z ENDDO ENDDO ENDDO * 4185 CONTINUE IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN INTERR(1)=IB CALL ERREUR(195) noer=195 GOTO 9980 ENDIF * * REMPLISSAGE DE XMATRI * CALL REMPMS(REL,LRE,RE(1,1,IB)) 3185 CONTINUE IF(IRTD.EQ.0) THEN MOTERR(1:8)=CMATE MOTERR(9:16)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF 9985 CONTINUE SEGSUP WRK1,WRK2,WRK3,WRK5,WRK55,WRK555 GOTO 510 * * ERREUR : CAS NON PREVU * 99 CONTINUE MOTERR(1:4)=NOMTP(MELE) MOTERR(5:12)='RIGI2 ' CALL ERREUR(86) * 510 CONTINUE * WRITE (*,*) 'Sortie de RIGI2.' * SEGDES,XMATRI SEGSUP,MVELCH c RETURN END