C EPSI1 SOURCE OF166741 26/03/13 21:15:02 12499 SUBROUTINE EPSI1(IDERI,MODORI,IPCHP1,IPCHA1,IPCHA2, 1 IMAT,IPEPSI,IRET,ipchp2,noer,kerr) C_______________________________________________________________________ C C OPERATEUR DEFORMATIONS APPELE PAR EPSI C C ENTREES : C _________ C c IDERI = | 1 si deformations LINEaires c | 2 si QUADratiques c | 3 si TRUEsdell, c | 4 si JAUMann c | 5 si UTILisateur C MODORI POINTEUR SUR UN MMODEL C IPCHP1 POINTEUR SUR UN CHAMPOINT DEPLACEMENT C IPCHA1 POINTEUR SUR UN MCHAML DE CARACTERISTIQUE (FACULTATIF) C IPCHA2 POINTEUR SUR UN MCHAML DE HOOKE (FACULTATIF) C IMAT Flag de HOOKE (2 si oui, 1 sinon) C C SORTIES : C _________ C C IPEPSI POINTEUR SUR UN MCHAML DE DEFORMATION C IRET 1 OU 0 SUIVANT SUCCES OU PAS C C----------------------------------------------------------------------- IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC CCREEL -INC CCHAMP C==DEB= FORMULATION HHO == INCLUDE ===================================== -INC CCHHOPA C==FIN= FORMULATION HHO ================================================ -INC SMCHAML -INC SMCHPOI -INC SMELEME -INC SMCOORD -INC SMMODEL -INC SMINTE -INC SMLREEL -INC TMPTVAL SEGMENT NOTYPE CHARACTER*16 TYPE(NBTYPE) ENDSEGMENT CHARACTER*8 CMATE CHARACTER*16 MO16 CHARACTER*(NCONCH) CONM PARAMETER (NINF=3) INTEGER INFOS(NINF) INTEGER ISUP1 LOGICAL LDPGE,lsupma,dcmate ISUP1=0 IRET = 0 IPEPSI = 0 kerr = 0 c on calcule les termes quadratiques seulement si deformations QUAD IF(IDERI.EQ.2) THEN IREPS2=1 ELSE IREPS2=0 ENDIF NHRM=NIFOUR C C ON VERIFIE QUE LE MCHAML DE CARACTERISTIQUES EST SUR SON SUPPORT C IF (IPCHA1.NE.0) THEN CALL QUESUP (MODORI,IPCHA1,5,0,ISUP1,IRET0) IF (ISUP1.GT.1) RETURN ELSE C SI massif jaumann et truesdel ==> manque un argument C IF() THEN C CALL ERREUR(404) C RETURN C ENDIF ENDIF C C ON VERIFIE QUE LE MCHAML DE HOOKE EST SUR SON SUPPORT C IF (IPCHA2.NE.0) THEN CALL QUESUP (MODORI,IPCHA2,5,1,ISUP2,IRET0) IF (ISUP2.NE.0) RETURN ENDIF C C ACTIVATION DU MODELE C C MODORI = Modele initial complet C IPMODL = Modele "deroule" (uniquement "MECANIQUE", "LIQUIDE" ou "POREUX") CALL PIMODL(MODORI,IPMODL,MAILDG,2) IF (IPMODL.EQ.0) RETURN C IPMODL est ACTIF en retour MMODEL=IPMODL NSOUS = KMODEL(/1) c*dbg write(ioimp,*) 'EPSI1=',MODORI,IPMODL,MAILDG,NSOUS C_______________________________________________________________________ C C ON CONVERTIT LE CHAMP POINT EN CHAMP PAR ELEMENT idem pour le 2eme C_______________________________________________________________________ CALL CHAME1 (0,IPMODL,IPCHP1,' ',IPCH1,1) IF (IERR.NE.0) RETURN ipch2=0 IF (ipchp2.ne.0) then call CHAME1 (0,IPMODL,IPCHP2,' ',IPCH2,1) IF (IERR.NE.0) RETURN ENDIF C C CREATION DU MCHELM C N1=NSOUS DO IJKL=1,NSOUS IMODEL=KMODEL(IJKL) IF (NEFMOD.EQ.22.OR.NEFMOD.EQ.259) N1 = N1 - 1 END DO L1=12 N3=6 SEGINI MCHELM mchelm.TITCHE='DEFORMATIONS' mchelm.IFOCHE=IFOUR C Un petit segment utile : NBTYPE = 1 SEGINI NOTYPE TYPE(1)='REAL*8' MOTYR8 = NOTYPE C_______________________________________________________________________ C C DEBUT DE LA BOUCLE SUR LES DIFFERENTES SOUS ZONES C_______________________________________________________________________ C ISOUS=0 DO 500 KISOUS=1,NSOUS C C INITIALISATION C IVAMAT=0 IVACAR=0 IVADEP=0 IVADE2=0 IVAEPS=0 IPMINT=0 MOCARA=0 MOMATR=0 lsupma=.true. C C ON RECUPERE L INFORMATION GENERALE C IMODEL = KMODEL(KISOUS) IPMAIL = IMAMOD CONM = CONMOD MELE = NEFMOD IF (MELE.EQ.22.OR.MELE.EQ.259) GOTO 502 C C CREATION DE TABLEAU INFOS C CALL IDENT(IPMAIL,CONM,IPCH1,IPCHA1,INFOS,IRTD) IF (IRTD.EQ.0) GOTO 9993 C C TRAITEMENT DU MODELE C if (formod(1).eq.'MELANGE'.and.CMATEE.EQ.'PARALLEL') then IF (IVAMOD(/1).GE.1) THEN DO j = 1,IVAMOD(/1) IF (TYMODE(j).EQ.'IMODEL ') THEN IMODE1 = IVAMOD(j) 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 imodel = imode1 goto 30 ENDIF ENDIF ENDDO ENDIF endif 30 continue C C NATURE DU MATERIAU C CMATE = CMATEE MATE = IMATEE INAT = INATUU dcmate = .false. do im = 1, matmod(/2) C Pour optimisation et eviter _gfortran_compare_string inefficace MO16=matmod(im) if (MO16 .eq. 'IMPEDANCE ') dcmate =.true. enddo C_______________________________________________________________________ C C INFORMATION SUR L ELEMENT FINI C_______________________________________________________________________ C NPINT = INFMOD(1) MFR = INFELE(13) IELE = INFELE(14) IPORE = INFELE(8) NBGS = INFELE(4) NEPSI = INFELE(16) LRE = INFELE(9) LW = INFELE(7) LHOOK = INFELE(10) c? IPGRAV=INFMOD(2+2) IPMINT=INFMOD(2+5) C IPMINT =INFELE(11) IPMIN1=INFMOD(3) MELEME = IPMAIL NBNN = NUM(/1) NBELEM = NUM(/2) ccc mele = imodel.nefmod if (dcmate) then if (itypel.eq.1) mele = 45 if (itypel.eq.2) mele = 2 endif IPPORE=0 IF(MFR.EQ.33.OR.MFR.EQ.57.OR.MFR.EQ.59) IPPORE=NBNN IF (IDERI.EQ.3.OR.IDERI.EQ.4) THEN C==DEB= FORMULATION HHO ================================================ IF (MELE.EQ.HHO_NUM_ELEMENT) THEN moterr = 'EPSI(HHO): IDERI = not compatible' write(moterr(20:20),FMT='(I1)') IDERI call erreur(-385) call erreur(21) return ENDIF C==FIN= FORMULATION HHO ================================================ IF (MFR.NE.1.AND.IPPORE.NE.1) THEN moterr = 'IDERI= ' write(moterr(8:8),FMT='(I1)') IDERI call erreur(803) return ENDIF ENDIF C C EXTRACTION DES DEPLACEMENTS DU NOEUD SUPPORT DE LA C DEFORMATION PLANE GENERALISEE (MECANIQUE) SI BESOIN C CALL INFDPG(MFR,IFOUR, LDPGE, ndpge) IF (LDPGE) THEN IIPDPG = imodel.IPDPGE IIPDPG = IPTPOI(IIPDPG) CALL DEPDPG(IPCHP1,UZDPG,RXDPG,RYDPG,IIPDPG) IF (IERR.NE.0) GOTO 9993 ELSE IIPDPG = 0 UZDPG=XZero RXDPG=XZero RYDPG=XZero ENDIF C C INITIALISATION DE MINTE C MINTE = IPMINT NBPGAU= minte.POIGAU(/1) if (NBGS.ne.NBPGAU) then write(ioimp,*) 'EPSI1 : Incoherence NBGS & NBPGAU',NBGS,NBPGAU call erreur(5) endif C_______________________________________________________________________ C C RECHERCHE DES NOMS COMPOSANTES C_______________________________________________________________________ C MOEPSI = lnomid(5) if (MOEPSI.eq.0) then write(ioimp,*) 'EPSI1 : moepsi=0',imodel call erreur(5) endif nomid = MOEPSI NDEFO = nomid.lesobl(/2) ndefac= nomid.lesfac(/2) C Cas particulier : if (ifomod.eq.6) then NEPSI = NDEFO + ndefac endif MODEPL = lnomid(1) if (modepl.eq.0) then write(ioimp,*) 'EPSI1 : modepl=0',imodel call erreur(5) endif nomid = MODEPL ndep = nomid.lesobl(/2) nfac = nomid.lesfac(/2) C_______________________________________________________________________ C C VERICIATION DE LA PRESENCE DES COMPOSANTES DE DEPLACEMENT C_______________________________________________________________________ C C==DEB= FORMULATION HHO ================================================ IF (MELE .EQ. HHO_NUM_ELEMENT) GOTO 2750 C==FIN= FORMULATION HHO ================================================ MOTYPE = MOTYR8 CALL KOMCHA(IPCH1,IPMAIL,CONM,MODEPL,MOTYPE,1,INFOS,3,IVADEP) IF (IERR.NE.0) GOTO 9993 C traitement du 2e champ par point if (ipch2.ne.0) then CALL KOMCHA(IPCH2,IPMAIL,CONM,MODEPL,MOTYPE,1,INFOS,3,IVADE2) IF (IERR.NE.0) GOTO 9993 ENDIF c-dbg : tests de verification if (iimpi.eq.1972) then NUPT = 0 NUEL = 0 MPTVAL = IVADEP DO ICOMP = 1, NDEP MELVAL = IVAL(ICOMP) NUPT = MAX(NUPT,VELCHE(/1)) NUEL = MAX(NUEL,VELCHE(/2)) ENDDO c-dbg IF (NUPT.EQ.1) THEN if (NUEL.EQ.1) then write(ioimp,*) 'DEPLACEMENT UNIFORME IVADEP',IVADEP,NUPT,NUEL else write(ioimp,*) 'DEPLACEMENT CST/ELT IVADEP',IVADEP,NUPT,NUEL endif ENDIF if (NUPT.EQ.1 .and. NBGS.ne.1) then write(ioimp,*) 'NUPT != NBGS',NUPT,NBGS,NUEL endif endif C==DEB= FORMULATION HHO == Etiquette speciale ========================== 2750 CONTINUE C==FIN= FORMULATION HHO ================================================ C_______________________________________________________________________ C C TAILLE DES MELVAL DU CHAMP DE DEFORMATIONS A ALLOUER C ON CONSIDERE LE CAS GENERAL (CHAMP VARIABLE EN TOUT POINT) C COMRED SE CHARGERA DE COMPACTER LES COMPOSANTES SI BESOIN C_______________________________________________________________________ C N1PTEL = NBGS N1EL = NBELEM N2PTEL = 0 N2EL = 0 NBPTEL = N1PTEL c NEL = N1EL C C CREATION DU MPTVAL CORRESPONDANT AU MCHAML DE LA SOUS ZONE C NSR=1 NCOSOR=NEPSI SEGINI MPTVAL DO ICOMP = 1, NEPSI SEGINI MELVAL IVAL(ICOMP) = MELVAL ENDDO IVAEPS = MPTVAL C en cas de derivee de truesdell et de Jaumann il faudra calculer C des contraintes donc on a besoin de la loi de hooke ou des C caracteristiques materiau ( young ...) C____________________________________________________________________ C C RANGEMENT DE LA MATRICE DE HOOKE DANS UN TABLEAU DE TRAVAIL * C____________________________________________________________________ C NGRA = 0 IF (IDERI.EQ.3.or.IDERI.eq.4) THEN C Cas de la derivee de Truesdell ou Jaumann IF (IPCHA1 .EQ. 0) THEN CALL ERREUR(404) RETURN ENDIF MOGRAD = imodel.LNOMID(3) if (MOGRAD.eq.0) then write(ioimp,*) 'EPSI - IDERI=3 ou 4 - MOGRAD = lnomid(3) = 0' call erreur(5) endif nomid = MOGRAD NGRA = nomid.LESOBL(/2) nfac = nomid.lesfac(/2) nbrobl=0 nbrfac=0 nomid = 0 C Sauf cas particuliers, les composantes sont de type REAL*8. notype = MOTYR8 IF (IMAT.EQ.2) THEN IF(MELE.EQ.93.AND.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 NMATR=NBROBL NMATF=NBRFAC NMATT=NMATR+NMATF MOMATR=NOMID MOTYPE=NOTYPE CALL KOMCHA(IPCHA2,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) ELSE C____________________________________________________________________ C C SINON TRAITEMENT DES CHAMPS DE MATERIAU C aussi obligatoire en massif pour truesdell et jaumann C____________________________________________________________________ C C Pour optimisation et eviter _gfortran_compare_string inefficace MO16=FORMOD(1) IF (MO16.EQ.'MECANIQUE '.AND.CMATE.EQ.'ISOTROPE') THEN NBROBL=2 SEGINI NOMID IF (MFR.EQ.35.or.mfr.eq.78) THEN LESOBL(1)='KS ' LESOBL(2)='KN ' ELSE IF(MFR.EQ.53) THEN NBROBL=1 SEGADJ,NOMID LESOBL(1)='KS ' ELSE LESOBL(1)='YOUN' LESOBL(2)='NU ' ENDIF ELSEIF(MO16.EQ.'MECANIQUE '.AND.CMATE.EQ.'UNIDIREC')THEN IF (MFR.EQ.1.AND.IDIM.EQ.3) THEN NBROBL=7 SEGINI NOMID LESOBL(1)='YOUN' LESOBL(2)='V1X ' LESOBL(3)='V1Y ' LESOBL(4)='V1Z ' LESOBL(5)='V2X ' LESOBL(6)='V2Y ' LESOBL(7)='V2Z ' ELSE NBROBL=3 SEGINI NOMID LESOBL(1)='YOUN' LESOBL(2)='V1X ' LESOBL(3)='V1Y ' ENDIF ELSEIF(MO16.EQ.'POREUX '.AND.CMATE.EQ.'ISOTROPE')THEN IF (MELE.GE.79.AND.MELE.LE.83) THEN NBROBL=4 SEGINI NOMID LESOBL(1)='YOUN' LESOBL(2)='NU ' LESOBL(3)='COB ' LESOBL(4)='MOB ' ELSE IF (MELE.GE.108.AND.MELE.LE.110) THEN NBROBL=4 SEGINI NOMID LESOBL(1)='KS ' LESOBL(2)='KN ' LESOBL(3)='COB ' LESOBL(4)='MOB ' ELSE IF (MELE.GE.173.AND.MELE.LE.177) THEN NBROBL=10 SEGINI NOMID LESOBL(1)='YOUN' LESOBL(2)='NU ' LESOBL(3)='COP1' LESOBL(4)='COP2' LESOBL(5)='CPP1' LESOBL(6)='CPP2' LESOBL(7)='KK11' LESOBL(8)='KK12' LESOBL(9)='KK21' LESOBL(10)='KK22' ELSE IF (MELE.GE.178.AND.MELE.LE.182) THEN NBROBL=17 SEGINI NOMID LESOBL(1)='YOUN' LESOBL(2)='NU ' LESOBL(3)='COP1' LESOBL(4)='COP2' LESOBL(5)='COP3' LESOBL(6)='CPP1' LESOBL(7)='CPP2' LESOBL(8)='CPP3' LESOBL(9)='KK11' LESOBL(10)='KK12' LESOBL(11)='KK13' LESOBL(12)='KK21' LESOBL(13)='KK22' LESOBL(14)='KK23' LESOBL(15)='KK31' LESOBL(16)='KK32' LESOBL(17)='KK33' ELSE IF (MELE.GE.185.AND.MELE.LE.187) THEN NBROBL=10 SEGINI NOMID LESOBL(1)='KS ' LESOBL(2)='KN ' LESOBL(3)='COP1' LESOBL(4)='COP2' LESOBL(5)='CPP1' LESOBL(6)='CPP2' LESOBL(7)='KK11' LESOBL(8)='KK12' LESOBL(9)='KK21' LESOBL(10)='KK22' ELSE IF (MELE.GE.188.AND.MELE.LE.190) THEN NBROBL=17 SEGINI NOMID LESOBL(1)='KS ' LESOBL(2)='KN ' LESOBL(3)='COP1' LESOBL(4)='COP2' LESOBL(5)='COP3' LESOBL(6)='CPP1' LESOBL(7)='CPP2' LESOBL(8)='CPP3' LESOBL(9)='KK11' LESOBL(10)='KK12' LESOBL(11)='KK13' LESOBL(12)='KK21' LESOBL(13)='KK22' LESOBL(14)='KK23' LESOBL(15)='KK31' LESOBL(16)='KK32' LESOBL(17)='KK33' ENDIF C ELSEIF(INAT.EQ.67.AND.CMATE.EQ.'ORTHOTRO') THEN NBROBL=6 SEGINI NOMID LESOBL(1)='YG1 ' LESOBL(2)='YG2 ' LESOBL(3)='NU12' LESOBL(4)='G12 ' LESOBL(5)='V1X ' LESOBL(6)='V1Y ' C Autres cas : ELSE nomid = lnomid(6) if(nomid.ne.0) then nbrobl=lesobl(/2) nbrfac=lesfac(/2) lsupma=.false. else CALL IDMATR(MFR,IMODEL,nomid,nbrobl,nbrfac) lsupma=.true. endif ENDIF NMATR=NBROBL NMATF=NBRFAC NMATT=NMATR+NMATF MOMATR=NOMID MOTYPE=NOTYPE CALL KOMCHA(IPCHA1,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT) IF (MOTYPE.NE.MOTYR8) SEGSUP,NOTYPE IF (IERR.NE.0) GOTO 9990 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 IM=1,NMATT MELVAL=IVAL(IM) 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 ENDDO ENDIF nmattd=nmatt ivamtd=ivamat ENDIF C_______________________________________________________________________ C C TRAITEMENT DES CHAMP CARACTERISTIQUES C_______________________________________________________________________ C NBROBL=0 NBRFAC=0 NOMID = 0 C Sauf cas particuliers, toutes les composantes sont de type REAL*8. notype = MOTYR8 C C EPAISSEUR ET EXCENTREMENT DANS LE CAS DES COQUES C IF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN NBROBL=1 NBRFAC=1 SEGINI NOMID LESOBL(1)='EPAI' LESFAC(1)='EXCE' C C SECTION POUR LES BARRES C ELSE IF (MFR.EQ.27) THEN IF(.NOT.dcmate) THEN NBROBL=1 SEGINI NOMID LESOBL(1)='SECT' ENDIF C C section, excentrements et orientation pour les barres excentrees C 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 ' C C raideurs locales et orientation pour l'element LIA2 C de liaison a 2 noeuds C 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 ' C C CARACTERISTIQUE POUR LES POUTRES C ELSE IF (MFR.EQ.7) THEN IF(.NOT.dcmate) THEN IF (CMATE.EQ.'SECTION ') THEN NBRFAC=3 SEGINI NOMID LESFAC(1)='VX' LESFAC(2)='VY' LESFAC(3)='VZ' ELSE IF(IFOUR.EQ.2) THEN 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' ELSEIF(IFOUR.EQ.-1.OR.IFOUR.EQ.-2.OR.IFOUR.EQ.63) THEN NBRFAC=1 NBROBL=2 SEGINI NOMID LESOBL(1)= 'SECT' LESOBL(2)= 'INRZ' LESFAC(1)= 'SECY' ENDIF ENDIF ENDIF C C TIMO 2D C C ELSE IF ((MFR.EQ.7).AND. C & (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3)) THEN C C IF (CMATE.NE.'SECTION') THEN C ENDIF C C CARACTERISTIQUE POUR LES TUYAUX C 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' C C CARACTERISTIQUE POUR LES LINESPRING C 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 ' C C CARACTERISTIQUE POUR LES TUYAUX FISSURES C 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' C C CARACTERISTIQUE POUR LES ELEMENTS HOMOGENEISES C 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 C CARACTERISTIQUE POUR LES JOINTS GENE C ELSE IF (MFR.EQ.55) THEN NBRFAC=1 SEGINI NOMID LESFAC(1)='EPAI' C C==DEB= FORMULATION HHO ================================================ ELSE IF (MFR.EQ.HHO_MFR_ELEMENT) THEN IF (MELE.EQ.HHO_NUM_ELEMENT) THEN nbrobl = 1 nbrfac = 0 SEGINI,nomid nomid.LESOBL(1) = 'BHHO' nbtype = 1 SEGINI,NOTYPE notype.TYPE(1) = 'POINTEURLISTREEL' END IF C==FIN= FORMULATION HHO ================================================ ENDIF C NCARA=NBROBL NCARF=NBRFAC NCARR=NCARA+NCARF MOCARA = nomid MOTYPE = notype IF (MOCARA.NE.0) THEN IF (IPCHA1.EQ.0) THEN MOTERR(1:8)='CARACTER' MOTERR(9:12)=NOMTP(MELE) MOTERR(13:20)='EPSI' CALL ERREUR(145) GOTO 9990 ENDIF CALL KOMCHA(IPCHA1,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS & ,3,IVACAR) IF (IERR.NE.0) GOTO 9990 IF(ISUP1.EQ.1)THEN CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE,MOCARA,MELE) IF(IERR.NE.0)THEN ISUP1=0 GOTO 9990 ENDIF ENDIF ENDIF IF (MOTYPE.NE.MOTYR8) SEGSUP,notype C____________________________________________________________________ C C RANGEMENT DE LA MATRICE DE HOOKE DANS UN TABLEAU DE TRAVAIL * C UNIQUEMENT DANS LE CAS DE L'ELEMENT COQUE DST C____________________________________________________________________ C NMATR=0 NMATF=0 NMATT=0 NBGMAT=0 NELMAT=0 IF(MELE.EQ.93.and.IMAT.EQ.2) THEN IF(CMATE.NE.'ISOTROPE')THEN NBROBL=3 NBRFAC=0 SEGINI NOMID LESOBL(1)='MAHO' LESOBL(2)='V1X ' LESOBL(3)='V1Y ' ELSE NBROBL=1 NBRFAC=0 SEGINI NOMID LESOBL(1)='MAHO' ENDIF MOMATR=NOMID NMATR=NBROBL NMATF=NBRFAC NMATT=NMATR+NMATF IF(CMATE.NE.'ISOTROPE')THEN NBTYPE=3 SEGINI NOTYPE TYPE(1)='POINTEURLISTREEL' TYPE(2)='REAL*8' TYPE(3)='REAL*8' ELSE NBTYPE=1 SEGINI NOTYPE TYPE(1)='POINTEURLISTREEL' ENDIF MOTYPE=NOTYPE CALL KOMCHA(IPCHA2,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) ENDIF C____________________________________________________________________ C C SINON TRAITEMENT DES CHAMPS DE MATERIAU C____________________________________________________________________ C IF((MELE.EQ.93.and.IMAT.ne.2).or. $ (mfr.eq.7.and.CMATE.NE.'SECTION '.and.(.not.dcmate)) $.or.mfr.eq.13)THEN C Pour optimisation et eviter _gfortran_compare_string inefficace MO16=FORMOD(1) IF ((MO16.EQ.'MECANIQUE '.AND.CMATE.EQ.'ISOTROPE') $ .or.mfr.eq.7) THEN NBROBL=2 NBRFAC=0 SEGINI NOMID MOMATR=NOMID LESOBL(1)='YOUN' LESOBL(2)='NU ' NMATR=NBROBL NMATF=NBRFAC ELSEIF(MO16.EQ.'MECANIQUE '.AND.(CMATE.EQ.'ORTHOTRO'))THEN IF(INAT.EQ.67) THEN NBROBL=6 NBRFAC=0 SEGINI NOMID MOMATR=NOMID LESOBL(1)='YG1 ' LESOBL(2)='YG2 ' LESOBL(3)='NU12' LESOBL(4)='G12 ' LESOBL(5)='V1X ' LESOBL(6)='V1Y ' NMATR=NBROBL NMATF=NBRFAC ELSE if(lnomid(6).ne.0) then lsupma=.false. nomid=lnomid(6) segact nomid momatr=nomid nmatr=lesobl(/2) nmatf=lesfac(/2) else CALL IDMATR(MFR,IMODEL,MOMATR,NMATR,NMATF) nomid=MOMATR endif ENDIF ELSE CALL ERREUR(19) GOTO 9990 ENDIF NMATT=NMATR+NMATF C Les composantes sont toutes de type 'REAL*8'. MOTYPE=MOTYR8 C CALL KOMCHA(IPCHA1,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT) IF (IERR.NE.0) GOTO 9990 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 C MPTVAL=IVAMAT NBGMAT = 0 NELMAT = 0 DO 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 ENDDO ENDIF 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(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 NMATT=NMATR+NMATF MOTYPE = MOTYR8 C CALL KOMCHA(IPCHA1,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT) IF (IERR.NE.0) GOTO 9990 C 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 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 ENDDO nmattd=nmatt ivamtd= ivamat ENDIF c*dbg write(ioimp,*) 'EPSI1',imodel,ISOUS,kisous,formod(1),mele,mfr C C======================================================================= C NUMERO DES ETIQUETTES : C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT C ON DIRIGE DANS 3 SOUS-PROGRAMMES SELON LES ELEMENTS C C - massif, poreux, joints poreux ------------------> epsi2 C - coq3,dkt,coq4,coq8,coq2,joints -----------------> epsi3 C - poutre,tuyau,linespring,tuyau fissure,barre ----> epsi4 C - elements XFEM (mfr = 63) -----------------------> epsix 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, 27, 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, 27, 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, 27, 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, 27, 34, 27 C CAF2 CAF3 XQ4R XC8R JOI1 ZCO2 ZCO3 ZCO4 TUY2 TUY3 6 , 34, 34, 63, 63, 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 , 281, 99, 99, 99, 99, 99, 99, 99, 99, 99 C .... .... .... .... .... .... .... .... .... .... 9 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99) c cccccc . ,MELE-200 ENDIF C 34 CONTINUE 99 CONTINUE MOTERR(1:4) =NOMTP(MELE) MOTERR(5:12)='EPSI' CALL ERREUR(86) GOTO 9990 C_______________________________________________________________________ C C massifs, poreux et joints poreux C_______________________________________________________________________ C 4 CONTINUE CALL EPSI2(IPMAIL,IPMINT,MELE,IELE,IVADEP,NBPTEL,LRE,NEPSI,LHOOK, & MFR,NDEP,IPORE,IREPS2,NBPGAU,IVAEPS,UZDPG,RYDPG,RXDPG,IIPDPG, & IDERI,IVAMTD,ivade2,mate,nmattD,cmate,NGRA,noer,kerr) GOTO 9990 C_______________________________________________________________________ C C poutres,tuyau,coq3,dkt,coq4,coq8,coq2,dst,joint 3D,joints 2D C_______________________________________________________________________ C 27 CONTINUE if (dcmate) goto 29 CALL EPSI3(IPMAIL,IVADEP,IVACAR,NELMAT,NBGMAT, & IVAMAT,LHOOK,IMAT,MATE,CMATE,NMATT,NEPSI,MFR,IPMINT, & NCARR,NDEP,NBPGAU,NBPTEL,MELE,LRE,LW,IREPS2,IVAEPS, & IPMIN1,UZDPG,RYDPG,RXDPG,NPINT,IIPDPG) GOTO 9990 C_______________________________________________________________________ C C linespring,tuyau fissure,barre,joi1,zone cohesive C_______________________________________________________________________ C 29 CONTINUE CALL EPSI4(IPMAIL,IVADEP,NDEP,IVAMAT,NMATT,IVACAR,NCARR,IPMINT, & MELE,LHOOK,IREPS2,NBPTEL,NEPSI,MFR, & NBPGAU,LRE,LW,IVAEPS,UZDPG,RYDPG,RXDPG,KISOUS,IIPDPG,cmate) GOTO 9990 C_______________________________________________________________________ C C Elements XFEM (MFR = 63) C_______________________________________________________________________ C 63 CONTINUE CALL EPSIX (IMODEL,IREPS2,IVADEP,IVAEPS, & UZDPG,RYDPG,RXDPG,IIPDPG,IRETER) IF (IRETER.NE.0) RETURN GO TO 9990 C==DEB= FORMULATION HHO ================================================ 281 CONTINUE CALL HHOEPS('EPSI', IMODEL, IPCHP1,MODEPL, & IIPDPG,UZDPG,RYDPG,RXDPG, & IVACAR, NCARA, IPMINT,NBPTEL, & IVAEPS,NEPSI, iret) IF (iret.NE.0) THEN CALL ERREUR(iret) RETURN END IF GO TO 9990 C==FIN= FORMULATION HHO ================================================ C_______________________________________________________________________ C C DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE IA C_______________________________________________________________________ 9990 CONTINUE IF (IMAT.NE.2.AND.ISUP1.EQ.1) THEN CALL DTMVAL(IVAMAT,3) ELSE CALL DTMVAL(IVAMAT,1) ENDIF IF (ISUP1.EQ.1) THEN CALL DTMVAL(IVACAR,3) ELSE CALL DTMVAL(IVACAR,1) ENDIF 9993 CONTINUE IF (IVADEP.NE.0) CALL DTMVAL(IVADEP,1) IF (IVADE2.NE.0) CALL DTMVAL(IVADE2,1) nomid = MOMATR IF (nomid.NE.0 .AND. lsupma) SEGSUP,nomid nomid = MOCARA IF (nomid.NE.0) SEGSUP,nomid C SORTIE PREMATUREE EN CAS D'ERREUR IF (IERR.NE.0) THEN IF (IVAEPS.NE.0) CALL DTMVAL(IVAEPS,3) GOTO 888 ENDIF C C REMPLISSAGE DU MCHAML DE LA SOUS-ZONE ISOUS C MPTVAL = IVAEPS NOMID = MOEPSI c* On doit avoir : ival(/1) = NEPSI = N2 N2 = NEPSI SEGINI MCHAML DO ICOMP = 1, NEPSI if (ifomod.eq.6) then if (icomp.le.NDEFO) then NOMCHE(ICOMP)=LESOBL(ICOMP) else NOMCHE(ICOMP)=LESFAC(ICOMP - NDEFO) endif else NOMCHE(ICOMP)=LESOBL(ICOMP) endif TYPCHE(ICOMP)='REAL*8' melval = IVAL(ICOMP) CALL COMRED(melval) IELVAL(ICOMP) = melval ENDDO CALL DTMVAL(IVAEPS,1) ISOUS=ISOUS+1 IMACHE(ISOUS) = IPMAIL CONCHE(ISOUS) = CONM ICHAML(ISOUS) = MCHAML INFCHE(ISOUS,1) = 0 INFCHE(ISOUS,2) = 0 INFCHE(ISOUS,3) = NHRM INFCHE(ISOUS,4) = IPMINT INFCHE(ISOUS,5) = 0 INFCHE(ISOUS,6) = 5 502 CONTINUE 500 CONTINUE C- FIN DU TRAITEMENT 888 CONTINUE mmodel = IPMODL SEGDES,mmodel meleme = MAILDG IF (meleme.NE.0) SEGDES,meleme notype = MOTYR8 SEGSUP,notype IF(IERR.NE.0)THEN IRET = 0 SEGSUP MCHELM IPEPSI = 0 ELSE IRET = 1 IPEPSI = MCHELM ENDIF c return END