C BSIGMP SOURCE OF166741 26/06/24 21:15:02 12550 SUBROUTINE BSIGMP(IPMOD0,IPCHE1,IPCHE2,IPCHE3,IMAT, 1 IPCHP4,IRET,noer) C_______________________________________________________________________ C C Entrees: C ________ C C IPMOD0 Pointeur sur un MMODEL C IPCHE1 Pointeur sur un MCHAML de contraintes C IPCHE2 Pointeur sur un MCHAML de caracteristiques (FACULTATIF) C IPCHE3 POINTEUR SUR UN MCHAML DE HOOKE (FACULTATIF) C IMAT Flag de HOOKE (2 si oui, 1 sinon) C IPCHP4 = 0 ou POINTEUR sur un CHPOINT de deplacements (FACULTATIF) C C SORTIES: C ________ C C IPCHP4 Pointeur sur un CHPOINT de forces aux noeuds C IRET = 1 OU 0 suivant succes ou pas (Message d'erreur C imprime dans ce cas) C C Passage aux nouveaux CHAMELEMs par I.Monnier le 13.06.90 C_______________________________________________________________________ C IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC CCHAMP C==DEB= FORMULATION HHO == Includes specifiques ======================== -INC CCHHOPA -INC CCHHOPR C==FIN= FORMULATION HHO ================================================ -INC SMMODEL -INC SMCHAML -INC SMCHPOI -INC SMELEME -INC SMINTE -INC SMLENTI POINTEUR MLPHAS.MLENTI -INC SMCOORD -INC TMPTVAL SEGMENT NOTYPE CHARACTER*16 TYPE(NBTYPE) ENDSEGMENT C==DEB= FORMULATION HHO == Pour FUSION champs HHO ====================== C SID : SEGMENT A REMPLIR POUR FUNOBJ (voir le sp pour son contenu) SEGMENT SID INTEGER IPOINT(NBFUS) LOGICAL BVAL (NBFUS) REAL*8 XVAL (NBFUS) CHARACTER*(IC1) CVAL (NBFUS) CHARACTER*8 CTYPE1,CREATE ENDSEGMENT C==FIN= FORMULATION HHO ================================================ C==DEB= FORMULATION HHO == Chpoint de forces a chaque zone HHO ========= POINTEUR mlehho.mlenti C==FIN= FORMULATION HHO ================================================ PARAMETER ( NINF=3 ) INTEGER INFOS(NINF) CHARACTER*8 CMATE CHARACTER*(NCONCH) CONM LOGICAL BDPGE,ldpge,lsupma,dcmate,b_z LOGICAL dphas,dcont1,dcont2 C On a besoin du MCOORD dans DOXE plus loin SEGACT,MCOORD C==DEB= FORMULATION HHO == Chpoint de deplacement ====================== IPCHPU = IPCHP4 C==FIN= FORMULATION HHO ================================================ IRET = 0 IPCHP4 = 0 noer = 0 isup1 = 0 isup2 = 0 isup3 = 0 mchaml = 0 llent2 = 0 klent2 = 0 mlphas = 0 C_______________________________________________________________________ C C ACTIVATION DU MODELE C_______________________________________________________________________ * On deroule le modele initial IPMOD0 et on ne garde que les sous- * modeles d interet -> on cree un nouveau modele IPMODL CALL PIMODL(IPMOD0,IPMODL,MAILDG,1) C IPMODL est ACTIF en retour : if (IPMODL.EQ.0) call erreur(21) if (ierr.ne.0) return mmodel = IPMODL NSOUS = mmodel.kmodel(/1) C==DEB= FORMULATION HHO == Quelques verifications ====================== kHHO = 0 DO im = 1, NSOUS imodel = mmodel.kmodel(im) IF (imodel.nefmod.EQ.HHO_NUM_ELEMENT) kHHO = kHHO + 1 END DO mleHHO = 0 IF (kHHO.GT.0) THEN IF (IPCHPU.EQ.0) THEN write(ioimp,*) 'HHO - BSIG: displacement field is missing!' call erreur(21) RETURN END IF CALL ACTOBJ('MAILLAGE',MPCHHO,1) CALL ACTOBJ('MAILLAGE',MPFHHO,1) CALL ACTOBJ('CHPOINT ',IPCHPU,1) if (ierr.ne.0) return jg = NSOUS SEGINI,mleHHO END IF C==FIN= FORMULATION HHO ================================================ * Suport recherche = STRESSES ISUPMO = 3 * * Verification du lieu support des MCHAML * * Contraintes : CALL QUESUP(IPMODL,IPCHE1,ISUPMO,0,ISUP1,iret1C) IF (ISUP1.GT.1) RETURN * Caracteristiques : IF (IPCHE2.NE.0) THEN CALL QUESUP(IPMODL,IPCHE2,ISUPMO,0,ISUP2,ir) IF (ISUP2.GT.1) RETURN ENDIF * Matrice.Hooke : IF (IPCHE3.NE.0) THEN CALL QUESUP(IPMODL,IPCHE3,ISUPMO,1,ISUP3,ir) IF (ISUP3.NE.0) RETURN ENDIF C C MCHAML DES CONTRAINTES C mchel1 = IPCHE1 C C INITIALISATION DU MCHELM DE FORCES C N1 = NSOUS L1 = 6 N3 = 6 CALL oooprl(1) SEGINI,mchelm IPCHE5 = mchelm mchelm.IFOCHE = IFOUR mchelm.TITCHE = 'FORCES' C C Cas des modes de calcul GENERALISES (2D et 1D) pour la mecanique : C On cree un CHPOINT local pour les forces sur les points supports : ICHPGE = 0 IF (IFOUR.EQ.-3) THEN BDPGE = .TRUE. NFORDG = 3 NC = NFORDG SEGINI,msoupo msoupo.NOCOMP(1) = 'FZ ' msoupo.NOCOMP(2) = 'MY ' msoupo.NOCOMP(3) = 'MX ' ELSE IF (IFOUR.EQ.11) THEN BDPGE = .TRUE. NFORDG = 2 NC = NFORDG SEGINI,msoupo msoupo.NOCOMP(1) = 'FZ ' msoupo.NOCOMP(2) = 'FY ' ELSE IF (IFOUR.EQ.9.OR.IFOUR.EQ.10.OR.IFOUR.EQ.14) THEN BDPGE = .TRUE. NFORDG = 1 NC = NFORDG SEGINI,msoupo msoupo.NOCOMP(1) = 'FZ ' ELSE IF (IFOUR.EQ.7.OR.IFOUR.EQ.8) THEN BDPGE = .TRUE. NFORDG = 1 NC = NFORDG SEGINI,msoupo msoupo.NOCOMP(1) = 'FY ' ELSE BDPGE = .FALSE. NFORDG = 0 ENDIF C On finit de remplir le CHPOINT en cas de DPGE : IF (BDPGE) THEN NSOUPO = 1 NAT = 1 SEGINI,mchpoi mchpoi.MTYPOI = ' ' mchpoi.MOCHDE = ' ' mchpoi.JATTRI(1) = 2 mchpoi.IPCHP(1) = msoupo mchpoi.IFOPOI = IFOUR C On cree un maillage de POI1 avec les points supports (sans redondance) nbnn = 1 nbelem = NSOUS nbref = 0 nbsous = 0 SEGINI,meleme meleme.itypel = 1 N_DPGE = 0 K_DPGE = 0 DO im = 1, NSOUS imodel = mmodel.kmodel(im) iipdpg = imodel.IPDPGE iipdpg = IPTPOI(iipdpg) IF (iipdpg.GT.0) THEN N_DPGE = N_DPGE + 1 meleme.num(1,N_DPGE) = iipdpg K_DPGE = im GOTO 1180 ENDIF ENDDO K_DPGE = NSOUS+1 1180 CONTINUE DO im = K_DPGE+1, NSOUS imodel = mmodel.kmodel(im) iipdpg = imodel.IPDPGE iipdpg = IPTPOI(iipdpg) IF (iipdpg.LE.0) GOTO 1190 DO jm = 1, N_DPGE IF (iipdpg.EQ.meleme.num(1,jm)) GOTO 1190 ENDDO N_DPGE = N_DPGE + 1 meleme.num(1,N_DPGE) = iipdpg 1190 CONTINUE ENDDO IF (N_DPGE.NE.NSOUS) THEN nbelem = N_DPGE SEGADJ,meleme ENDIF msoupo.IGEOC = meleme C On cree les valeurs de forces GENE nulles au depart : N = N_DPGE NC = NFORDG SEGINI,mpoval msoupo.IPOVAL = mpoval ICHPGE = mchpoi ENDIF CALL oooprl(0) K_DPGE = 0 C un petit segment toujours utile : NBTYPE=1 SEGINI,NOTYPE TYPE(1)='REAL*8' MOTYR8 = NOTYPE C_______________________________________________________________________ C C BOUCLE SUR LES SOUS ZONES C_______________________________________________________________________ C ISOUS = 0 * DO 200 KISOUS = 1, NSOUS * * INITIALISATION * IVAMAT=0 IVACAR=0 IVASTR=0 IVAFOR=0 MOMATR=0 MOCARA=0 MOSTRS=0 MOFORC=0 lsupma=.true. IPMINT=0 mophas = 0 C C TRAITEMENT DU MODELE C imodel = mmodel.kmodel(KISOUS) MELE = imodel.NEFMOD c pas de contribution if (mele.eq.259) goto 200 ISOUS = ISOUS+1 IPMAIL = imodel.IMAMOD CONM = imodel.CONMOD IIPDPG = imodel.IPDPGE IIPDPG = IPTPOI(IIPDPG) C C CREATION DU TABLEAU INFOS C CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,IRTD) IF (IRTD.EQ.0) GOTO 9991 C if (formod(1).eq.'MELANGE'.and.CMATEE.EQ.'PARALLEL') then mophas = lnomid(12) nomid = mophas nmpha = lesobl(/2) nmphf = lesfac(/2) jg = nmpha + nmphf NPHAT=JG if (mlphas.gt.0) then * verifie que le precedent melange a ete totalement traite do iph = 1,mlphas.lect(/1) if (mlphas.lect(iph).gt.0) then c write(6,*) 'bsigmp-melange incompletement traite' call erreur(5) return endif enddo segadj mlphas elseif (mlphas.eq.0) then if (IPCHE2.gt.0) segini mlphas endif IVAPHA = 0 imoref = 0 imosou = imodel * associe phase et coefficient de phase IF (IVAMOD(/1).GE.1) THEN DO j = 1,IVAMOD(/1) IF (TYMODE(j).EQ.'IMODEL ') THEN IMODE1 = IVAMOD(j) * SEGACT,IMODE1 IF (IMODE1.FORMOD(1)(1:10).EQ.'MECANIQUE ' .OR. & IMODE1.FORMOD(1)(1:10).EQ.'POREUX ' .OR. & IMODE1.FORMOD(1)(1:16).EQ.'ELECTROSTATIQUE ' .OR. & IMODE1.FORMOD(1)(1:10).EQ.'LIQUIDE ' ) THEN do iph = 1,nmpha if (imode1.conmod(17:24).eq.lesobl(iph)) then if (mlphas.gt.0) mlphas.lect(iph) = imode1 if (imoref.eq.0) imoref = imode1 endif enddo ELSE C SEGDES,IMODE1 ENDIF ENDIF ENDDO ELSE c write(6,*) 'traitement MELANGE - 1 ' call erreur(21) return ENDIF if (imoref.eq.0) then c write(6,*) 'traitement MELANGE - 2 ' call erreur(21) return endif C if (IPCHE2.gt.0) then MOTYPE = MOTYR8 CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOPHAS,MOTYPE,0,INFOS,3,IVAPHA) IF (IERR.NE.0) GOTO 9992 nomid = mophas mptval = ivapha dphas = .false. do iph = 1,nmpha if (ival(iph).eq.0) dphas = .true. enddo else IVAPHA = 0 endif if (ivapha.gt.0) then mptval = IVAPHA if (dphas) then * massif / manque proportions phases / imite imoref / conserve CONM moterr(1:50) = 'attention pas trouve proportions de phases' call erreur(-385) interr(1) = imodel moterr(1:16) = conm moterr(17:24) = ' ' call erreur(-386) imodel = imoref elseif (ival(/1).ge.nmpha) then goto 200 else c write(6,*) 'traitement MELANGE - 3 ' call erreur(21) return endif else * massif / pas de proportions phases / imite imoref / conserve CONM imodel = imoref endif IF(ISUP.EQ.1)THEN CALL VALCHE(IVAPHA,NPHAT,IPMINT,IPPORE,MOPHAS,MELE) IF(IERR.NE.0)THEN ISUP=0 GOTO 9991 ENDIF ENDIF IF (IERR.NE.0) GOTO 9992 endif iphas = 0 melpha = 0 if (mlphas.gt.0.and.ivapha.gt.0) then mptval = ivapha do iph =1,NPHAT if (imodel.eq.mlphas.lect(iph)) then iphas = iph melpha = ival(iphas) mlphas.lect(iph) = 0 endif enddo endif C C COQUE INTEGREE OU PAS ? NPINT = INFMOD(1) C C NATURE DU MATERIAU C CMATE = CMATEE MATE = IMATEE INAT = INATUU dcmate = .FALSE. DO im = 1, imodel.matmod(/2) IF (imodel.matmod(im).EQ.'IMPEDANCE') dcmate = .TRUE. ENDDO C____________________________________________________________________ C C ACTIVATION DU MELEME C MELEME = IPMAIL if (dcmate) then if (itypel.eq.1) mele = 45 if (itypel.eq.2) mele = 2 endif NBNN = meleme.NUM(/1) NBELEM = meleme.NUM(/2) C_______________________________________________________________________ C C INFORMATIONS SUR L'ELEMENT FINI C_______________________________________________________________________ C C Support : STRESSES = 3 sauf cas particulier(s) ISUPMO = 3 IF (infmod(/1).lt.2+ISUPMO) then write(ioimp,*) 'BSIGMP : INFMOD(/1) <',2+ISUPMO,imodel call erreur(5) ENDIF NBPGAU= INFELE(4) MINTE = INFMOD(5) MINTE1= INFMOD(3) MFR = INFELE(13) NSTRS = INFELE(16) LHOOK = INFELE(10) LW = INFELE(7) LRE = INFELE(9) IPORE = INFELE(8) if (MFR.EQ.73) then ISUPMO = 6 call tshape(mele,'GAUSS',minte) minte1 = 0 nbpgau = minte.poigau(/1) endif IPMINT= MINTE IPMIN1= MINTE1 NHRM = NIFOUR IPPORE =0 IF (MFR.EQ.33.OR.MFR.EQ.57.OR.MFR.EQ.59) IPPORE = NBNN C Informations en DPGE pour le (sous-)modele courant C Si ldpge est VRAI, alors ndpge = NFORDG, sinon ndpge = 0. CALL INFDPG(MFR,IFOUR, ldpge,ndpge) IMACHE(ISOUS) = IPMAIL INFCHE(ISOUS,1)=0 INFCHE(ISOUS,2)=0 INFCHE(ISOUS,3)=NIFOUR INFCHE(ISOUS,4)=IPMINT INFCHE(ISOUS,5)=0 INFCHE(ISOUS,6)=ISUPMO C__________________________________ C C NOMS DE COMPOSANTES NECESSAIRES ( CONTRAINTES ) C_______________________________________________________________________ C MOSTRS = lnomid(4) if (mostrs.eq.0) then write(ioimp,*) 'BSIGMP : MOSTRS=lnomid(4)=0 !',imodel call erreur(5) endif nomid = mostrs nstr = nomid.lesobl(/2) nfac = nomid.lesfac(/2) if (cmate.eq.'MODAL'.or.cmate.eq.'STATIQUE') then * recherche composante FMOD if (llent2.eq.0) then jg = NSOUS jgl2 = jg segini mlent2 llent2 = mlent2 endif do im2 = 1, mchel1.imache(/1) if (mchel1.imache(im2).eq.imamod.and. & mchel1.conche(im2).eq.conmod) then mcham2 = mchel1.ichaml(im2) do in2 = 1, mcham2.nomche(/2) if (mcham2.nomche(in2)(1:4).eq.'FMOD') then melva2 = mcham2.ielval(in2) if (klent2 + melva2.ielche(/2).gt.jgl2) then jgl2 = jgl2 + melva2.ielche(/2) jg = jgl2 segadj mlent2 endif do iel2 = 1,melva2.ielche(/2) klent2 = klent2 + 1 mlent2.lect(klent2) = melva2.ielche(1,iel2) enddo goto 11 endif enddo endif enddo 11 continue *JK truande le test komcha IF(NSTRS.LT.1) THEN CALL ERREUR(922) GO TO 9990 ENDIF mostrs0 = mostrs if (ifomod.eq.6) then nbrobl = 1 nbrfac = 1 segini nomid lesobl(1) = 'EFFX' lesfac(1) = 'IFFX' else nbrobl = 1 nbrfac = 0 segini nomid lesobl(1) = 'EFFX' endif mostrs = nomid else IF(NSTR+NFAC.NE.NSTRS) THEN CALL ERREUR(922) GO TO 9990 ENDIF endif C C VERIFICATION DE LEUR PRESENCE C MOTYPE = MOTYR8 icond = 0 if (melpha.gt.0) icond = 1 CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOSTRS,MOTYPE,icond,INFOS,3,IVASTR) IF (IERR.NE.0) GOTO 9991 if (melpha.eq.0) then mptval = ivastr nomid = mostrs dcont1 = .false. dcont2 = .false. if (ival(/1).ge.lesobl(/2)) then do ic = 1,lesobl(/2) if (ival(ic).le.0) dcont1 = .true. if (ival(ic).gt.0) dcont2 = .true. enddo else dcont1 = .true. endif if (dcont1) then if (dcont2) then c write(6,*) ' composantes contraintes incompletes cons ',conmod call erreur(21) return else * aucune composante de contrainte pour le constituant : au suivant goto 200 endif endif endif C if (cmate.eq.'MODAL'.or.cmate.eq.'STATIQUE') then mptval = ivastr segact mptval*mod nsr = ipos(/1) ncosor = 0 jg = ival(/1) segini mlenti do ico = 1,ival(/1) if (ival(ico).gt.0) then ncosor = ncosor + 1 lect(ncosor) = ival(ico) endif enddo segadj mptval do ico = 1,ncosor ival(ico) = lect(ico) enddo segsup mlenti segsup nomid mostrs = mostrs0 endif C IF (ISUP1.EQ.1) THEN ifai=1 if( mele.eq.260.and.iret1c.eq.5) ifai=0 IF (ifai.eq.1) CALL VALCHE(IVASTR,NSTRS,IPMINT,IPPORE, & MOSTRS,MELE) ENDIF C_______________________________________________________________________ C C NOMS DE COMPOSANTES NECESSAIRES ( FORCES ) C_______________________________________________________________________ C MOFORC = lnomid(2) if (MOFORC.eq.0) then write(ioimp,*) 'BSIGMP : MOFORC=lnomid(2)=0 !',imodel call erreur(5) endif nomid = MOFORC NFORC = nomid.lesobl(/2) nfacf = nomid.lesfac(/2) C C CREATION DU MCHAML C C CAS PARTICULIER DE LA DEFO PLANE GENE : RIEN SUR FZ MY MX C C* NFOREF=NFORC C* IF (ldpge) NFOREF = NFOREF - ndpge NFOREF = NFORC - ndpge c N2=NFOREF c bp: les composantes facultatives peuvent elles aussi exister ! * on ajustera apres bsigmx la taille reellement utilisee par la force N2=NFOREF+NFACF if (cmate.eq.'MODAL'.or.cmate.eq.'STATIQUE') then if (ncosor.lt.n2) then *jk : rustique nfacf = 0 n2 = ncosor nforef = ncosor endif endif C==DEB= FORMULATION HHO ================================================ C On va calculer directement le chpoint de forces pour chaque sous-zone. C On ne passe pas dans ce cas par un MCHAML de forces. On va le creer C mais il sera vide dans les zones associees a la formulation HHO. IF (MFR.EQ.HHO_MFR_ELEMENT .AND. MELE.EQ.HHO_NUM_ELEMENT) THEN NFOREF = 0 NFAREF = 0 N2 = 0 END IF C==FIN= FORMULATION HHO ================================================ C C TAILLES DE MELVAL C N1EL =NBELEM N1PTEL=NBNN N2PTEL=0 N2EL =0 NBPTEL=NBPGAU NEL =N1EL C C CREATION DU MELVAL DE FORCES C NSR=1 NCOSOR=NFOREF+NFACF CALL oooprl(1) SEGINI MCHAML SEGINI MPTVAL DO ICOMP=1,NCOSOR SEGINI MELVAL IELVAL(ICOMP)=MELVAL IVAL(ICOMP)=MELVAL ENDDO CALL oooprl(0) ICHAML(ISOUS)=MCHAML IVAFOR=MPTVAL DO ICOMP=1,NFOREF NOMCHE(ICOMP)=LESOBL(ICOMP) TYPCHE(ICOMP)='REAL*8' ENDDO if(NFACF .ne. 0) then IFAC = 0 DO ICOMP=(NFOREF+1),N2 IFAC = IFAC + 1 NOMCHE(ICOMP)=LESFAC(IFAC) TYPCHE(ICOMP)='REAL*8' ENDDO endif C____________________________________________________________________ C * TRAITEMENT DES CHAMPS DE CARACTERISTIQUES * C____________________________________________________________________ NBROBL=0 NBRFAC=0 NOMID=0 IVECT=0 * Sauf indication contraire, les composantes sont toutes de type REAL*8 NOTYPE = MOTYR8 * * EPAISSEUR DANS LE CAS MASSIF EN CONTRAINTES PLANES * IF((MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.63.OR. + (MELE.GE.79.AND.MELE.LE.83)).AND. + IFOUR.EQ.-2)THEN * NBRFAC=1 SEGINI NOMID LESFAC(1)='DIM3' * * EPAISSEUR ET EXCENTREMENT DANS LE CAS DES COQUES * ELSEIF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN NBROBL=1 IF(MFR.EQ.3.AND.IFOUR.EQ.-2) THEN NBRFAC=2 ELSE NBRFAC=1 ENDIF SEGINI NOMID LESOBL(1)='EPAI' LESFAC(1)='EXCE' IF(MFR.EQ.3.AND.IFOUR.EQ.-2) LESFAC(2)='DIM3' * * SECTION POUR LES BARRES * ELSE IF (MFR.EQ.27) THEN IF(.NOT.dcmate) THEN NBROBL=1 SEGINI NOMID LESOBL(1)='SECT' ENDIF * * section, excentrements et orientation pour les barres excentrees * ELSE IF (MFR.EQ.49) THEN NBROBL=6 SEGINI NOMID LESOBL(1)='SECT' LESOBL(2)='EXCZ' LESOBL(3)='EXCY' LESOBL(4)='VX ' LESOBL(5)='VY ' LESOBL(6)='VZ ' * * raideurs locales et orientation pour l'element LIA2 * de liaison a 2 noeuds * ELSE IF (MFR.EQ.51) THEN NBROBL=9 SEGINI NOMID LESOBL(1)='RLUX' LESOBL(2)='RLUY' LESOBL(3)='RLUZ' LESOBL(4)='RLRX' LESOBL(5)='RLRY' LESOBL(6)='RLRZ' LESOBL(7)='VX ' LESOBL(8)='VY ' LESOBL(9)='VZ ' * * CARACTERISTIQUES POUR LES POUTRES * ELSE IF (MFR.EQ.7 ) THEN if (dcmate) then NBRFAC=6 SEGINI NOMID LESFAC(1)='TORS' LESFAC(2)='INRY' LESFAC(3)='INRZ' LESFAC(4)='VX' LESFAC(5)='VY' LESFAC(6)='VZ' IVECT=1 else IF (CMATE.EQ.'SECTION') THEN NBRFAC=3 SEGINI NOMID LESFAC(1)='VX' LESFAC(2)='VY' LESFAC(3)='VZ' IVECT=1 * ELSEIF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN NBROBL=2 NBRFAC=1 SEGINI NOMID LESOBL(1)='SECT' LESOBL(2)='INRZ' LESFAC(1)='SECY' * ELSE NBROBL=4 NBRFAC=5 SEGINI NOMID LESOBL(1)='TORS' LESOBL(2)='INRY' LESOBL(3)='INRZ' LESOBL(4)='SECT' LESFAC(1)='SECY' LESFAC(2)='SECZ' LESFAC(3)='VX' LESFAC(4)='VY' LESFAC(5)='VZ' IVECT=1 ENDIF endif * * CARACTERISTIQUES POUR LES TUYAUX * ELSE IF (MFR.EQ.13) THEN NBROBL=2 NBRFAC=5 SEGINI NOMID LESOBL(1)='EPAI' LESOBL(2)='RAYO' LESFAC(1)='RACO' LESFAC(2)='CISA' LESFAC(3)='VX' LESFAC(4)='VY' LESFAC(5)='VZ' IVECT=1 * * CARACTERISTIQUES POUR LES LINESPRING * ELSE IF (MFR.EQ.15) THEN NBROBL=5 SEGINI NOMID LESOBL(1)='EPAI' LESOBL(2)='FISS' LESOBL(3)='VX ' LESOBL(4)='VY ' LESOBL(5)='VZ ' * * CARACTERISTIQUES POUR LES TUYAUX FISSURES * ELSE IF (MFR.EQ.17) THEN NBROBL=9 SEGINI NOMID LESOBL(1)='RAYO' LESOBL(2)='EPAI' LESOBL(3)='VX ' LESOBL(4)='VY ' LESOBL(5)='VZ ' LESOBL(6)='VXF ' LESOBL(7)='VYF ' LESOBL(8)='VZF ' LESOBL(9)='ANGL' * * CARACTERISTIQUES DES ELEMENTS HOMOGENEISES * ELSE IF (MFR.EQ.37) THEN IF(IFOUR.EQ.1.OR.IFOUR.EQ.0) THEN NBROBL=4 SEGINI NOMID LESOBL(1)='SCEL' LESOBL(2)='SFLU' LESOBL(3)='EPS ' LESOBL(4)='XINE' ELSE NBROBL=3 SEGINI NOMID LESOBL(1)='SCEL' LESOBL(2)='SFLU' LESOBL(3)='EPS ' ENDIF * C CARACTERISTIQUE POUR LES JOINTS GENE C ELSE IF (MFR.EQ.55) THEN NBROBL=0 NBRFAC=1 SEGINI NOMID LESFAC(1)='EPAI' c c element coaxial COS2 (3D pour liaison acier-beton) c ELSE IF( MFR.EQ.78) THEN NBROBL=1 NBRFAC=0 SEGINI NOMID LESOBL(1)='SECT' C==DEB= FORMULATION HHO ================================================ ELSE IF (MFR.EQ.HHO_MFR_ELEMENT) THEN IF (MELE.EQ.HHO_NUM_ELEMENT) THEN nbrobl = 2 nbrfac = 0 SEGINI,nomid nomid.LESOBL(1) = 'PIHO' nomid.LESOBL(2) = 'BHHO' MOCARA = nomid nbtype = 2 SEGINI,NOTYPE notype.TYPE(1) = 'REAL*8 ' notype.TYPE(2) = 'POINTEURLISTREEL' END IF C==FIN= FORMULATION HHO ================================================ ENDIF MOCARA=NOMID * rendement kich 09/01 /// a remettre en cause avec phases (kich 04/09) if (MOCARA.EQ.0) then nbrobl = 0 nbrfac = 0 segini nomid mocara = nomid endif MOTYPE = NOTYPE ifac = nbrfac NCAR1=NBROBL + NBRFAC + 1 NBRFAC= nbrfac + 10 segadj nomid lesfac(ifac + 1) = 'REND' lesfac(ifac + 2) = 'W1X ' lesfac(ifac + 3) = 'W1Y ' lesfac(ifac + 4) = 'W1Z ' lesfac(ifac + 5) = 'W2X ' lesfac(ifac + 6) = 'W2Y ' lesfac(ifac + 7) = 'W2Z ' lesfac(ifac + 8) = 'REN1' lesfac(ifac + 9) = 'REN2' lesfac(ifac + 10)= 'REN3' if (motype.ne.MOTYR8) then notype = motype nbtype = notype.type(/2) + 1 segadj notype type(nbtype) = 'REAL*8' endif * NCARA=NBROBL NCARF=NBRFAC NCARR=NCARA+NCARF C* IF (MOCARA.NE.0) THEN IF (IPCHE2.gt.0) THEN icond = 1 if (ncara.le.0) icond = 0 CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,MOTYPE,icond, $ INFOS,3,IVACAR) IF (IERR.NE.0) GOTO 9990 IF (ISUP2.EQ.1.and.mele.ne.260) THEN CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE,MOCARA,MELE) IF (IERR.NE.0)THEN ISUP2=0 GOTO 9990 ENDIF ENDIF ELSE IF (NCARA.GT.0) THEN MOTERR(1:8)='CARACTER' MOTERR(9:12)=NOMTP(MELE) MOTERR(13:20)='BSIGMA' CALL ERREUR(145) GOTO 9990 ENDIF C* ENDIF if (motype.ne.MOTYR8) then notype = motype segsup,notype endif mptval = ivacar if (ivacar.gt.0) then dphas = .true. do iv = 1,ival(/1) if (ival(iv).gt.0) dphas = .false. enddo if (dphas) ivacar = 0 endif C____________________________________________________________________ C * RANGEMENT DE LA MATRICE DE HOOKE DANS UN TABLEAU DE TRAVAIL * * UNIQUEMENT DANS LE CAS DE L'ELEMENT COQUE DST C____________________________________________________________________ * NBGMAT = 0 NELMAT = 0 NMATR = 0 NMATF = 0 NMATT = 0 IF(MELE.EQ.93.or.mele.eq.260)THEN IF (IMAT.EQ.2) THEN NBRFAC=0 IF(CMATE.NE.'ISOTROPE')THEN NBROBL=3 SEGINI NOMID LESOBL(1)='MAHO' LESOBL(2)='V1X ' LESOBL(3)='V1Y ' NBTYPE=3 SEGINI NOTYPE TYPE(1)='POINTEURLISTREEL' TYPE(2)='REAL*8' TYPE(3)='REAL*8' ELSE NBROBL=1 SEGINI NOMID LESOBL(1)='MAHO' NBTYPE=1 SEGINI NOTYPE TYPE(1)='POINTEURLISTREEL' ENDIF MOMATR=NOMID MOTYPE=NOTYPE CALL KOMCHA(IPCHE3,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT) SEGSUP NOTYPE IF (IERR.NE.0) GOTO 9990 MPTVAL=IVAMAT MELVAL=IVAL(1) NBGMAT=IELCHE(/1) NELMAT=IELCHE(/2) NMATR=NBROBL NMATF=NBRFAC NMATT=NMATR+NMATF ELSE C____________________________________________________________________ * * SINON TRAITEMENT DES CHAMPS DE MATERIAU C____________________________________________________________________ * NBROBL=0 NBRFAC=0 IF (FORMOD(1).EQ.'MECANIQUE'.AND.CMATE.EQ.'ISOTROPE') THEN NBROBL=2 SEGINI NOMID MOMATR=NOMID LESOBL(1)='YOUN' LESOBL(2)='NU ' ELSEIF(FORMOD(1).EQ.'MECANIQUE'.AND.CMATE.EQ.'ORTHOTRO')THEN IF(INAT.EQ.67) THEN NBROBL=6 SEGINI NOMID MOMATR=NOMID LESOBL(1)='YG1 ' LESOBL(2)='YG2 ' LESOBL(3)='NU12' LESOBL(4)='G12 ' LESOBL(5)='V1X ' LESOBL(6)='V1Y ' ELSE if(lnomid(6).ne.0) then nomid=lnomid(6) momatr=nomid nbrobl=lesobl(/2) nbrfac=lesfac(/2) lsupma=.false. else CALL IDMATR(MFR,IMODEL,MOMATR,NBROBL,NBRFAC) endif ENDIF ENDIF NMATR=NBROBL NMATF=NBRFAC NMATT=NMATR+NMATF * IF (MOMATR.NE.0) THEN MOTYPE = MOTYR8 CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT) IF (IERR.NE.0) GOTO 9990 * IF (ISUP2.EQ.1.and.mele.ne.260) THEN CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE,MOMATR,MELE) IF (IERR.NE.0)THEN ISUP2=0 GOTO 9990 ENDIF ENDIF * MPTVAL=IVAMAT NBGMAT = 0 NELMAT = 0 DO IM=1,NMATT IF(IVAL(IM).NE.0)THEN MELVAL=IVAL(IM) NBGMAT=MAX(NBGMAT,VELCHE(/1)) NELMAT=MAX(NELMAT,VELCHE(/2)) ENDIF ENDDO ENDIF ENDIF ENDIF C C================================================ C C CAS D'UN JOINT UNIDIMENSIONNEL JOI1 C Chargement des vecteurs situes dans les caracteristiques materiau C C================================================ IF(MFR.EQ.75) THEN IF(IFOUR.EQ.2) 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(IFOUR.EQ.-2.OR.IFOUR.EQ.-1) THEN NBROBL=2 NBRFAC=0 SEGINI NOMID MOMATR=NOMID LESOBL(1)='V1X' LESOBL(2)='V1Y' NMATR=NBROBL NMATF=NBRFAC ENDIF MOTYPE=MOTYR8 * CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT) IF (IERR.NE.0) GOTO 9990 * NMATT=NMATR+NMATF * C IF(ISUP1.EQ.1)THEN CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE,MOMATR,MELE) 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 ENDIF C_______________________________________________________________________ C C NUMERO DES ETIQUETTES : C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT C Les elements sont groupes comme suit : C - massif, poreux, joints poreux,incompressibles --> BSIGM1 C - coq3,dkt,coq4,coq8,coq2,jot3,joi4,joi2,joi3 ----> BSIGM2 C - poutre,tuyau,linespring,tuyau fissure,barre ----> BSIGM3 c et poutre Timoschenko, cos2, coa2 C_______________________________________________________________________ C IF(MELE.GE.1.AND.MELE.LE.100) THEN C CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8 GOTO ( 99, 29, 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, 27, 27, 29, 29 C FAC3 FAC4 FAC6 FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5 3 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 C COQ8 TUYA TUFI COQ2 POI1 BARR RACO LSU2 COQ4 LISM 4 , 27, 29, 29, 27, 29, 29, 99, 99, 27, 29 C COF3 RES2 LSU3 LSU4 LICO COQ6 CVS2 CVS3 CVT3 CVT6 5 , 99, 99, 99, 99, 99, 27, 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, 4, 4 C CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4 JOI6 JOI8 8 , 4, 4, 4, 29, 27, 27, 27, 27, 99, 99 C LISC TRIH DST LIC4 CERC TUYO LSE2 LITU HYT3 HYQ4 9 , 99, 99, 27, 99, 29, 29, 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, 4, 4, 4 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, 29, 29, 29, 34, 34, 34, 34, 34 C QUF4 CUF8 PRF6 TEF4 PYF5 MSE3 MTR6 MQU9 MC27 MP18 3 , 34, 34, 34, 34, 34, 34, 34, 34, 34, 34 C MT10 MP14 SEF3 TRF7 QUF9 CF27 PF21 TF15 PF19 SEG6 4 , 34, 34, 34, 34, 34, 34, 34, 34, 34, 34 C TR21 QU36 C216 P126 TE56 PY91 TRH6 BSE2 BTR4 BQU5 5 , 34, 34, 34, 34, 34, 34, 34, 34, 34, 34 C BCU9 BPR7 BTE5 BPY6 FRO4 SEGS POJS JCT3 JCI4 JGI2 6 , 34, 34, 34, 34, 34, 34, 34, 27, 27, 27 C JGT3 JGI4 TRIQ QUAQ CUBQ TETQ PRIQ TRIR QUAR CUBR 7 , 27, 27, 4, 4, 4, 4, 4, 4, 4, 4 C TETR PRIR Q4RI Q8RI JOQ3 JOQ6 JOQ8 JOR3 JOR6 JOR8 8 , 4, 4, 4, 4, 4, 4, 4, 4, 4, 4 C T1D2 T1D3 M1D2 M1D3 LC03 LC07 LC09 LC27 LC21 LC15 9 , 34, 34, 4, 4, 34, 34, 34, 34, 34, 34) 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 ( 34, 34, 34, 34, 34, 34, 34, 34, 34, 34 C BS09 BS27 BS21 BS15 BS19 MC03 MC07 MC09 MC27 MC21 1 , 34, 34, 34, 34, 34, 34, 34, 34, 34, 34 C MC15 MC19 M103 M107 M109 M127 M121 M115 M119 MS03 2 , 34, 34, 34, 34, 34, 34, 34, 34, 34, 34 C MS07 MS09 MS27 MS21 MS15 MS19 QC03 QC07 QC09 QC27 3 , 34, 34, 34, 34, 34, 34, 34, 34, 34, 34 C QC21 QC15 QC19 Q103 Q107 Q109 Q127 Q121 Q115 Q119 4 , 34, 34, 34, 34, 34, 34, 34, 34, 34, 34 C QS03 QS07 QS09 QS27 QS21 QS15 QS19 CIFL SURE SHB8 5 , 34, 34, 34, 34, 34, 34, 34, 34, 34, 29 C CAF2 CAF3 XQ4R XC8R JOI1 ZCO2 ZCO3 ZCO4 TUY2 TUY3 6 , 34, 34, 34, 34, 29, 29, 29, 29, 99, 99 C COS2 COA2 ICY5 IC13 CU27 PR21 TE15 PY19 C20R P15R 7 , 29, 29, 4, 4, 4, 4, 4, 4, 4, 4 C HHO .... .... .... .... .... .... .... .... .... 8 , 34, 34, 34, 34, 34, 34, 34, 34, 34, 34 C ... .... .... .... .... .... .... .... .... .... 9 , 34, 34, 34, 34, 34, 34, 34, 34, 34, 34) c cccccc . ,MELE-200 ENDIF C 34 CONTINUE C Cas particulier de la Formulation DIFFUSION : IF (MFR.EQ.73) GOTO 4 C==DEB= FORMULATION HHO ================================================ IF (MFR.EQ.HHO_MFR_ELEMENT) THEN IF (MELE.EQ.HHO_NUM_ELEMENT) THEN CALL HHOBSG(IMODEL, MOFORC, IVASTR,NSTRS, & IIPDPG, ADPG,BDPG,CDPG, & IVACAR,NCARA, IPMINT,NBPGAU, & IPCHPU, IVAFOR, iret) IF (iret.NE.0) THEN CALL ERREUR(iret) GOTO 9990 END IF mleHHO.lect(ISOUS) = IVAFOR GOTO 510 END IF END IF C==FIN= FORMULATION HHO ================================================ C_______________________________________________________________________ C POUR les XFEM on fait un cas particuliers IF(MFR.EQ.63) THEN CALL BSIGMX (IMODEL,IVACAR,IVASTR,ncar1,NFORC, & IVAFOR,ADPG,BDPG,CDPG,IIPDPG,IRETER) IF(IRETER.NE.0) RETURN MPTVAL = IVAFOR N1TOT = IPOS(/1) N1SUP = N1TOT - 1 N2TOT = IVAL(/1) * si le nombre de sous-zones fournies par BSIGMX doit augmenter... c write(6,*) N1TOT,N1SUP,N2TOT,N1,NFOREF,NFACF IF (N1SUP.ge.1) THEN N1 = N1 + N1SUP segadj,MCHELM ENDIF I2TOT = 0 I1NN = 1 DO I1=1,(1+N1SUP) * -cas ou la zone est vide if (IPOS(I1).eq.0) then N1 = N1 - 1 segadj,MCHELM I2TOT = I2TOT + NSOF(I1) if(I1.eq.I1NN) I1NN=I1NN+1 * -cas ou il faut remplir ICHAML avec MCHAM1 = copie du MCHAML pere else N2=NFOREF+NFACF segini,MCHAM1=MCHAML * la 1ere fois est reperee par I1NN if(I1.ne.I1NN) ISOUS = ISOUS + 1 ICHAML(ISOUS) = MCHAM1 c write(6,*) 'bsigmp: creation de ICHAML(',ISOUS,')=',MCHAM1 IMACHE(ISOUS) = IPOS(I1) N2 = NSOF(I1) segadj,MCHAM1 do i2=1,N2 I2TOT = I2TOT + 1 MCHAM1.IELVAL(i2) = IVAL(I2TOT) enddo endif ENDDO * Quand on a fini avec cette zone on n oublie pas de supprimer * le MCHAML pere des MCHAM1. c * Dans le cas ou ils n ont pas ete utilises, c * les MELVAL du MCHAML pere peuvent etre supprimes aussi. c if (IPOS(1).eq.0) then c DO IB=1,IELVAL(/1) c MELVAL=IELVAL(IB) c SEGSUP MELVAL c ENDDO c endif * -> cela semble etre une erreur car les melval sont utilises !!! SEGSUP MCHAML GO TO 510 ENDIF C fin des XFEM _________________________________________________________ 99 CONTINUE MOTERR(1:4)=NOMTP(MELE) MOTERR(5:12)='BSIGMA' CALL ERREUR(86) GOTO 9990 C_______________________________________________________________________ C C massifs, poreux, joints poreux, incompressibles C_______________________________________________________________________ C 4 CONTINUE IF (MFR.EQ.71) THEN CALL BSIGEL(IPMAIL,IPMINT,NBPGAU,IVASTR,NSTRS,LRE,LHOOK, & IVAFOR,NFORC) ELSE IF (MFR.EQ.73) THEN CALL BSIGDI(IPMAIL,IPMINT,NBPGAU,IVASTR,NSTRS,LRE,LHOOK, & IVAFOR,NFORC) ELSE CALL BSIGM1(IPMAIL,LRE,NSTRS,NBPGAU,MELE,MFR,IVASTR,IPMINT, & IVACAR,IPORE,LHOOK,NFORC,IVAFOR,ADPG,BDPG,CDPG, & IIPDPG,ncar1,melpha,noer) if (noer.eq.195) return ENDIF GOTO 510 C_______________________________________________________________________ C C coq3,dkt,coq4,coq8,coq2,dst,jot3,joi4,joi2,joi3 C_______________________________________________________________________ C 27 CONTINUE if (dcmate) goto 29 CALL BSIGM2(IPMAIL,LRE,NSTRS,IVASTR,LW,NBPGAU,IVACAR,CMATE,NBPTEL, & MELE,MFR,IPMINT,IPMIN1,IVAMAT,NMATT,NBGMAT,NELMAT,IMAT,NPINT, & NFORC,IVAFOR,ADPG,BDPG,CDPG,IIPDPG) GOTO 510 C_______________________________________________________________________ C C poutre,tuyau,linespring,tuyau fissure,barre,poutre Timoschenko C joi1, zone_cohesive, cos2, coa2 C_______________________________________________________________________ C 29 CONTINUE ncaru = ncar1 - 1 CALL BSIGM3(IPMAIL,LRE,NSTRS,LW,IVACAR,ncaru,IVECT,MELE,CMATE, &IVASTR,ISOUS,NBPGAU,NBPTEL,IPMINT,NFORC,IVAFOR,ADPG,BDPG,CDPG &,IIPDPG,ivamat,NMATT,MFR,dcmate) GOTO 510 C_______________________________________________________________________ C C DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE ISOUS C_______________________________________________________________________ C 510 CONTINUE C C Cas des modes de calculs GENEralises : C IF (ldpge) THEN K_DPGE = K_DPGE + 1 mchpoi = ICHPGE msoupo = mchpoi.ipchp(1) ipt1 = msoupo.IGEOC DO im = 1, N_DPGE IF (iipdpg.EQ.ipt1.num(1,im)) GOTO 300 ENDDO write(ioimp,*) 'BSIGMP - incoherence iipdpg / ipt1' CALL erreur(5) 300 CONTINUE mpoval = msoupo.IPOVAL mpoval.vpocha(im,1) = mpoval.vpocha(im,1) + ADPG IF (NFORDG.GE.2) THEN mpoval.vpocha(im,2) = mpoval.vpocha(im,2) + BDPG IF (NFORDG.GE.3) THEN mpoval.vpocha(im,3) = mpoval.vpocha(im,3) + CDPG ENDIF ENDIF ENDIF IF(ISUP1.EQ.1)THEN CALL DTMVAL(IVASTR,3) ELSE CALL DTMVAL(IVASTR,1) ENDIF * CALL DTMVAL(IVAFOR,1) * IF(ISUP2.EQ.1.AND.IMAT.NE.2)THEN CALL DTMVAL(IVAMAT,3) ELSE CALL DTMVAL(IVAMAT,1) ENDIF * IF(ISUP2.EQ.1)THEN CALL DTMVAL(IVACAR,3) ELSE CALL DTMVAL(IVACAR,1) ENDIF * NOMID=MOCARA IF (MOCARA.NE.0) SEGSUP NOMID NOMID=MOMATR IF (MOMATR.NE.0.and.lsupma) SEGSUP NOMID * IF (IERR.NE.0) GO TO 9991 C 200 CONTINUE C_______________________________________________________________________ C C TRANSFORMATION DU CHAMELEM EN CHPOINT C_______________________________________________________________________ C IF (NSOUS.NE.kHHO) CALL CHAMPO(IPCHE5,0,IPCHP4,IRET) if (ierr.ne.0) return C==DEB= FORMULATION HHO ================================================ IF (kHHO.GT.0) THEN NBFUS = kHHO IF (NSOUS.NE.kHHO) NBFUS = NBFUS + 1 IF (NBFUS.EQ.1) THEN ipchp6 = 0 DO im = 1, NSOUS ip = mleHHO.lect(im) IF (ip.NE.0) THEN if (ipchp6.ne.0) then write(ioimp,*) 'BSIGMP-NBFUS-ipchp6' call erreur(5) return end if ipchp6 = ip END IF END DO ELSE ic1 = 0 SEGINI,sid sid.CTYPE1 = 'CHPOINT ' sid.CREATE = 'BSIGMA ' i = 0 IF (NSOUS.NE.kHHO) THEN i = i + 1 sid.IPOINT(i) = IPCHP4 END IF DO im = 1, NSOUS ip = mleHHO.lect(im) IF (ip.NE.0) THEN i = i + 1 sid.IPOINT(i) = ip END IF END DO if (i.ne.khho) write(ioimp,*) 'ERREUR HHO BSIG SID !' r_z = 0. b_z = .TRUE. CALL FUNOBJ(sid,ipchp6,r_z,b_z) IF (NSOUS.NE.kHHO) CALL DTCHPO(IPCHP4) SEGSUP,sid END IF IPCHP4 = ipchp6 SEGSUP,mleHHO END IF C==FIN= FORMULATION HHO ================================================ C C CAS des modes de calculs GENERALISEs : C ON ADDITIONNE LE CHPOINT RESULTANT DE LA TRANSFORMATION DU CHAMELEM C ET LE PETIT CHPOINT DES FORCES INTERNES AUx NOEUDs supports C IF (BDPGE) THEN IF (K_DPGE.NE.0) THEN CALL ADCHPO(ICHPGE,IPCHP4,IPCHP6,1D0,1D0) CALL DTCHPO(IPCHP4) IPCHP4 = IPCHP6 ENDIF CALL DTCHPO(ICHPGE) ENDIF C IF (llent2.gt.0) then ipc1 = ipchp4 jg = klent2 segadj mlent2 do ipj= 1,jg ipcj = mlent2.lect(ipj) if (ipcj.gt.0) then call adchpo(ipc1,ipcj,ipc2,1.D0,1.D0) call dtchpo(ipc1) ipc1 = ipc2 endif enddo ipchp4 = ipc1 segsup mlent2 ENDIF C IPCHE5 est maintenant inutile ! MCHELM = IPCHE5 DO im=1,ICHAML(/1) MCHAML=mchelm.ICHAML(im) IF (MCHAML.GT.0) THEN DO jm=1,IELVAL(/1) MELVAL=mchaml.IELVAL(jm) SEGSUP,MELVAL ENDDO SEGSUP,MCHAML ENDIF ENDDO SEGSUP,MCHELM C* Fin normale IRET = 1 GOTO 9000 * * ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR * 9990 CONTINUE * IF(ISUP1.EQ.1)THEN CALL DTMVAL(IVASTR,3) ELSE CALL DTMVAL(IVASTR,1) ENDIF * CALL DTMVAL(IVAFOR,3) * IF(ISUP2.EQ.1.AND.IMAT.NE.2)THEN CALL DTMVAL(IVAMAT,3) ELSE CALL DTMVAL(IVAMAT,1) ENDIF * IF(ISUP2.EQ.1)THEN CALL DTMVAL(IVACAR,3) ELSE CALL DTMVAL(IVACAR,1) ENDIF * NOMID=MOCARA IF (MOCARA.NE.0) SEGSUP NOMID NOMID=MOMATR IF (MOMATR.NE.0.and.lsupma) SEGSUP NOMID 9991 CONTINUE 9992 CONTINUE IRET = 0 C Dernieres desactivations avant de quitter : 9000 CONTINUE meleme = MAILDG IF (meleme.NE.0) SEGDES,meleme notype = MOTYR8 SEGSUP,notype c RETURN END