Télécharger feqpr.eso

Retour à la liste

feqpr
C FEQPR     SOURCE    CB215821  24/04/12    21:15:57     11897          
      SUBROUTINE FEQPR(IPMODL,IPCHM1,IPCHM2,IPCHP4,IRET)
C_______________________________________________________________________
C
C  ENTREES:
C  ________
C
C     IPMODL  Pointeur sur un MMODEL
C     IPCHM1  Pointeur sur un MCHAML de CONTRAINTES
C     IPCHM2  Pointeur sur un MCHAML de CARACTERISTIQUES
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
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
C
 
-INC PPARAM
-INC CCOPTIO
-INC CCHAMP
-INC SMMODEL
-INC SMCHAML
-INC SMCHPOI
-INC SMELEME
-INC SMINTE
-INC SMLENTI
C
      SEGMENT NOTYPE
        CHARACTER*16 TYPE(NBTYPE)
      ENDSEGMENT
C
      SEGMENT MPTVAL
        INTEGER IPOS(NS)    ,NSOF(NS)
        INTEGER      IVAL(NCOSOU)
        CHARACTER*16 TYVAL(NCOSOU)
      ENDSEGMENT
C
      SEGMENT LIMODL(0)
C
      PARAMETER ( NINF=3 )
      INTEGER INFOS(NINF)
      CHARACTER*8 CMATE
      CHARACTER*(NCONCH) CONM
C_______________________________________________________________________
C
C     A T-ON BIEN UN MMODEL CHARGEMENT PRESSION
C_______________________________________________________________________
C
      MMODEL=IPMODL
      SEGACT,MMODEL
      NSOUS = MMODEL.KMODEL(/1)
      SEGINI, LIMODL
      DO ISOUS = 1,NSOUS
        IMODEL = MMODEL.KMODEL(ISOUS)
        SEGACT, IMODEL
        IF (FORMOD(1).EQ.'CHARGEMENT') THEN
          LIMODL(**) = IMODEL
        ENDIF
      ENDDO
C
      NSOUS = LIMODL(/1)
      IF (NSOUS.EQ.0) THEN
        MOTERR(1:10)='un MMODEL '
        MOTERR(11:20)='CHARGEMENT'
        MOTERR(21:30)=' PRESSION '
        CALL ERREUR(881)
        RETURN
      ENDIF
C
C     TEST DE NON REDONDANCES DES SOUS-MODELES
C
      N1 = 1
      DO I = NSOUS,2,-1
        IMODE1 = LIMODL(I)
        DO J = (I-1),1,-1
          IMODE2 = LIMODL(J)
          IF (IMODE1.EQ.IMODE2) THEN
            LIMODL(I) = 0
            GOTO 10
          ELSE IF (IMODE1.IMAMOD.EQ.IMODE2.IMAMOD .AND.
     &             IMODE1.CONMOD.EQ.IMODE2.CONMOD) THEN
            LIMODL(I) = 0
            GOTO 10
          ENDIF
        ENDDO
        N1 = N1 + 1
 10     CONTINUE
      ENDDO
C
C     CREATION DU MMODEL
C
      J = 0
      SEGINI,MMODE1
      DO i = 1,NSOUS
        IF (LIMODL(I).GT.0) THEN
          j = j + 1
          MMODE1.KMODEL(J) = LIMODL(I)
        ENDIF
      ENDDO
      IPMOD0 = MMODE1
      SEGSUP, LIMODL
C_______________________________________________________________________
C
C     QUELQUES INITIALISATIONS
C_______________________________________________________________________
C
      ISUP1  = 0
      ISUP2  = 0
      IRET   = 0
      IPCHP4 = 0
      MCHELM = 0
      MCHAML = 0
      IPCHE1 = 0
      IPCHE2 = 0
C_______________________________________________________________________
C
C     REDUCTION DES MCHAML EN ENTREE SUR LE MODELE
C_______________________________________________________________________
C
C     DEJA FAIT DANS BSIGMA
      IF (IPCHM1.NE.0) THEN
        CALL REDUAF(IPCHM1,IPMOD0,IPCHE1,0,IR,KER)
        IF (IR.NE.1) CALL ERREUR(KER)
        IF (IERR.NE.0) RETURN
      ENDIF
C
      IF (IPCHM2.NE.0) THEN
        CALL REDUAF(IPCHM2,IPMOD0,IPCHE2,0,IR,KER)
        IF (IR.NE.1) CALL ERREUR(KER)
        IF (IERR.NE.0) RETURN
      ENDIF
C_______________________________________________________________________
C
C     VERIFICATION DES LIEUX SUPPORT DES MCHAML
C_______________________________________________________________________
C
      IF (IPCHE1.NE.0) THEN
        CALL QUESUP(IPMOD0,IPCHE1,3,0,ISUP1,IRET1C)
        IF (ISUP1.GT.1) RETURN
      ENDIF
C
      IF (IPCHE2.NE.0) THEN
        CALL QUESUP(IPMOD0,IPCHE2,3,0,ISUP2,IR)
        IF (ISUP2.GT.1) RETURN
      ENDIF
C_______________________________________________________________________
C
C     ACTIVATION DU MODELE
C_______________________________________________________________________
C
      MMODEL=IPMOD0
      SEGACT, MMODEL
      NSOUS = MMODEL.KMODEL(/1)
      DO IM = 1, NSOUS
        IMODEL = MMODEL.KMODEL(IM)
        SEGACT, IMODEL
      ENDDO
C
C     ACTIVATION DU MCHELM CONTENANT 'PRES'
C
      IF (IPCHE1.NE.0) THEN
        MCHEL1 = IPCHE1
      ELSE
        MCHEL1 = IPCHE2
      ENDIF
      SEGACT, MCHEL1
C
C     INITIALISATION DU MCHELM DE FORCES
C
      N1 = NSOUS
      L1 = 6
      N3 = 5
      SEGINI, MCHELM
      IPCHE5 = MCHELM
      MCHELM.IFOCHE = IFOUR
      MCHELM.TITCHE = 'FORCES'
C
C=======================================================================
C
C     BOUCLE SUR LES MODELES ELEMENTAIRES
C
C=======================================================================
C
      ISOUS = 0
C
      DO 200 KISOUS = 1, NSOUS
C
C       INITIALISATION
C
        IVAMAT=0
        IVACAR=0
        IVASTR=0
        IVAFOR=0
        MOMATR=0
        MOCARA=0
        MOSTRS=0
        MOFORC=0
        IPMINT=0
        IPMIN1=0
C
C       TRAITEMENT DU MODELE
C
        IMODEL = MMODEL.KMODEL(KISOUS)
        ISOUS  = ISOUS+1
        MELE   = IMODEL.NEFMOD
C
C       PETITE VERIFICATION SUR LE TYPE D'ELEMENT
C
        IF (MELE.EQ.0) THEN
C
C         ERREUR : IMPOSSIBLE D UTILISER L OPERATEUR PRESSI POUR
C                  LES ELEMENTS DE FORMULATION MELE
C
          MOTERR(1:8)=NOMTP(MELE)
          CALL ERREUR(193)
          GOTO 9992
        ENDIF
        IPMAIL = IMODEL.IMAMOD
        CONM   = IMODEL.CONMOD
C
C       CREATION DU TABLEAU INFOS
C
        CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,IRTD)
        IF (IRTD.EQ.0) GOTO 9992
C
C       NATURE DU MATERIAU
C
        CMATE = CMATEE
        MATE = IMATEE
        INAT = INATUU
C_______________________________________________________________________
C
C       ACTIVATION DU MELEME
C_______________________________________________________________________
C
        MELEME = IPMAIL
        SEGACT, MELEME
        NBNN   = MELEME.NUM(/1)
        NBELEM = MELEME.NUM(/2)
C_______________________________________________________________________
C
C       INFORMATIONS SUR L'ELEMENT FINI
C_______________________________________________________________________
C
        NBPGAU= INFELE(4)
        MINTE = INFMOD(5)
        MINTE1= INFMOD(8)
        MFR   = INFELE(13)
        MFR2  = NUMMFR(MELE)
        NSTRS = INFELE(16)
C
        IPMINT= MINTE
        IPMIN1= MINTE1
        SEGACT, MINTE
        IPPORE= 0
        IF (MFR2.EQ.33.OR.MFR2.EQ.57.OR.MFR2.EQ.59) IPPORE = NBNN
C
        IMACHE(ISOUS) = IPMAIL
        INFCHE(ISOUS,1)=0
        INFCHE(ISOUS,2)=0
        INFCHE(ISOUS,3)=NIFOUR
        INFCHE(ISOUS,4)=0
        INFCHE(ISOUS,5)=0
C_______________________________________________________________________
C
C       NOMS DE COMPOSANTES DE CONTRAINTES
C_______________________________________________________________________
C
        IF (IPCHE1.NE.0) THEN
          MOSTRS=LNOMID(4)
          NOMID=MOSTRS
          SEGACT, NOMID
          NSTR=LESOBL(/2)
          NFAC=LESFAC(/2)
C
          NBTYPE=1
          SEGINI, NOTYPE
          TYPE(1)='REAL*8'
          MOTYPE=NOTYPE
C
C         VERIFICATION DE LEUR PRESENCE
C
          CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOSTRS,MOTYPE,1,INFOS,3,IVASTR)
          SEGSUP, NOTYPE
          IF (IERR.NE.0) GOTO 9991
C
          IF (ISUP1.EQ.1) THEN
            NSTRS = 1
            CALL VALCHE(IVASTR,NSTRS,IPMINT,IPPORE,MOSTRS,MELE)
          ENDIF
        ELSE
          MOMATR=LNOMID(6)
          NOMID=MOMATR
          SEGACT, NOMID
          NMATR=LESOBL(/2)
          NMATF=LESFAC(/2)
C
          NBTYPE=1
          SEGINI, NOTYPE
          TYPE(1)='REAL*8'
          MOTYPE=NOTYPE
C
C         VERIFICATION DE LEUR PRESENCE
C
          CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT)
          SEGSUP, NOTYPE
          IF (IERR.NE.0) GOTO 9991
C
          IF (ISUP2.EQ.1) THEN
            CALL VALCHE(IVAMAT,NMATR,IPMINT,IPPORE,MOMATR,MELE)
          ENDIF
        ENDIF
C_______________________________________________________________________
C
C       NOMS DE COMPOSANTES DE FORCES ET CREATION DU MCHAML DE FORCE
C       (CE MCHAML SERA TRANSFORME EN FIN DE SUBROUTINE EN CHPOINT)
C_______________________________________________________________________
C
        MOFORC = LNOMID(2)
        NOMID=MOFORC
        SEGACT, NOMID
        NFORC=LESOBL(/2)
        NFACF=LESFAC(/2)
C
        N2=NFORC
        SEGINI, MCHAML
        ICHAML(ISOUS)=MCHAML
C
        DO 110 ICOMP=1,NFORC
          NOMCHE(ICOMP)=LESOBL(ICOMP)
          TYPCHE(ICOMP)='REAL*8'
 110    CONTINUE
C
        IF (NFACF.NE.0) THEN
          IFAC = 0
          DO 111 ICOMP=(NFORC+1),N2
            IFAC = IFAC + 1
            NOMCHE(ICOMP)=LESFAC(IFAC)
            TYPCHE(ICOMP)='REAL*8'
 111      CONTINUE
        ENDIF
C
C       TAILLES DE MELVAL
C
        N1EL=NBELEM
        N1PTEL=NBNN
        NBPTEL=NBPGAU
        NEL   =N1EL
C
C       CREATION DU MELVAL DE FORCES
C
        NS=1
        NCOSOU=NFORC+NFACF
        SEGINI, MPTVAL
        IVAFOR=MPTVAL
        DO 100 ICOMP=1,NCOSOU
          N2PTEL=0
          N2EL=0
          SEGINI, MELVAL
          IELVAL(ICOMP)=MELVAL
          IVAL(ICOMP)=MELVAL
 100    CONTINUE
C_______________________________________________________________________
C
C       NOMS DE COMPOSANTES DE CARACTERISTIQUES (FACULTATIF)
C_______________________________________________________________________
C
        NBROBL=0
        NBRFAC=0
        NOMID=0
        IVECT=0
C
C       EPAISSEUR DANS LE CAS MASSIF EN CONTRAINTES PLANES
C
        IF(MFR.EQ.72.AND.IFOUR.EQ.-2)THEN
C
          NBRFAC=1
          SEGINI, NOMID
          LESFAC(1)='DIM3'
C
          NBTYPE=1
          SEGINI, NOTYPE
          TYPE(1)='REAL*8'
C
C       EPAISSEUR DANS LE CAS DES COQUES 2D COQ2
C
        ELSEIF(MFR.EQ.74.AND.MELE.EQ.44.AND.IFOUR.EQ.-2)THEN
C
          NBRFAC=1
          SEGINI, NOMID
          LESFAC(1)='DIM3'
C
          NBTYPE=1
          SEGINI, NOTYPE
          TYPE(1)='REAL*8'
C
C       EPAISSEUR DANS LE CAS DES COQUES EPAISSES
C
        ELSEIF (MFR.EQ.74.AND.MFR2.EQ.5) THEN
          NBROBL=1
          NBRFAC=0
          SEGINI, NOMID
          LESOBL(1)='EPAI'
C
          NBTYPE=1
          SEGINI, NOTYPE
          TYPE(1)='REAL*8'
C
C       EPAISSEUR ET RAYON EXTERNE DANS LE CAS DES TUYAUX
C
        ELSEIF (MFR.EQ.74.AND.MFR2.EQ.13) THEN
          NBROBL=2
          NBRFAC=4
          SEGINI, NOMID
          LESOBL(1)='EPAI'
          LESOBL(2)='RAYO'
          LESFAC(1)='RACO'
          LESFAC(2)='VX'
          LESFAC(3)='VY'
          LESFAC(4)='VZ'
C
          NBTYPE=4
          SEGINI, NOTYPE
          TYPE(1)='REAL*8'
          TYPE(2)='REAL*8'
          TYPE(3)='REAL*8'
          TYPE(4)='REAL*8'
          TYPE(5)='REAL*8'
          TYPE(6)='REAL*8'
C
        ENDIF
        MOCARA=NOMID
        MOTYPE=NOTYPE
C
        NCARA=NBROBL
        NCARF=NBRFAC
        NCARR=NCARA+NCARF
C
        IF (IPCHE2.NE.0) THEN
          IF (MOCARA.NE.0) THEN
            CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3,
     +                      IVACAR)
            SEGSUP, NOTYPE
            SEGSUP, NOMID
            IF (IERR.NE.0) GOTO 9990
            IF (ISUP2.EQ.1) THEN
              CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE,MOCARA,MELE)
              IF (IERR.NE.0)THEN
                ISUP2=0
                GOTO 9990
              ENDIF
            ENDIF
          ELSE
            SEGSUP, NOTYPE
            SEGSUP, NOMID
          ENDIF
        ELSE IF (NCARA.GT.0) THEN
          SEGSUP, NOTYPE
          SEGSUP, NOMID
          MOTERR(1:8)='CARACTER'
          MOTERR(9:12)=NOMTP(MELE)
          MOTERR(13:20)='FEQPR'
          CALL ERREUR(145)
          GOTO 9990
        ENDIF
C_______________________________________________________________________
C
C       CALCUL DES FORCES EQUIVALENTES
C_______________________________________________________________________
C
        IF (IPCHE1.NE.0) THEN
          MPTVAL=IVASTR
        ELSE
          MPTVAL=IVAMAT
        ENDIF
        IVAPRE = IVAL(1)
C
C       - ELEMENTS DE FORMULATION MASSIF
C
        IF (MFR2.EQ.1) THEN
          XP=0.D0
          IF (MELE.EQ.2.OR.MELE.EQ.3.OR.MELE.EQ.79.OR.MELE.EQ.80) THEN
            CALL FPMA2D(IVAPRE,IPMAIL,IPMINT,IVAFOR,IVACAR,XP)
          ELSE IF(MELE.EQ.4.OR.MELE.EQ.6.OR.MELE.EQ.8.OR.
     +            MELE.EQ.10.OR.MELE.EQ.81.OR.MELE.EQ.82.OR.
     +            MELE.EQ.83) THEN
            IF (IDIM.EQ.3) THEN
              CALL FPMA3D(IVAPRE,IPMAIL,IPMINT,IVAFOR,XP)
            ELSE
C             ERREUR, APPLICATION PRESSION SUR SURFACE DANS UN PB 2D
              CALL ERREUR(820)
              GOTO 9990
            ENDIF
          ELSE IF (MELE.EQ.45) THEN
              CALL FPMA1D(IVAPRE,IPMAIL,IPMINT,IVAFOR,XP)
          ELSE
C           ERREUR, ELEMENT NON IMPLEMENTE
            MOTERR(1:4)=NOMTP(MELE)
            MOTERR(5:12)='FEQPR '
            CALL ERREUR(86)
            GOTO 9990
          ENDIF
C
C       - ELEMENTS DE FORMULATION COQUES
C
        ELSE IF (MFR2.EQ.3.OR.MFR2.EQ.5.OR.MFR2.EQ.9) THEN
C
          IF (MELE.EQ.27.OR.MELE.EQ.28.OR.MELE.EQ.45.OR.
     +        MELE.EQ.93.OR.MELE.EQ.44.OR.MELE.EQ.49.OR.
     +        MELE.EQ.41.OR.MELE.EQ.56) THEN
C           VERIFICATION DE L ORIENTATION DU IPMAIL
            CALL ECROBJ('MAILLAGE',IPMAIL)
            CALL VERSEN
            CALL LIROBJ('MAILLAGE',IPMAIL,1,IRETOU)
            IF (IERR.NE.0) GOTO 9990
            IF (MELE.EQ.27.OR.MELE.EQ.28.OR.MELE.EQ.45
     +                                  .OR.MELE.EQ.93) THEN
              CALL FPCO3D(IVAPRE,IPMAIL,IVAFOR)
            ELSE IF (MELE.EQ.44) THEN
              CALL FPCO2D(IVAPRE,IPMAIL,IVAFOR,IVACAR)
            ELSE IF (MELE.EQ.49) THEN
              IPT1 = IPMAIL
              SEGACT, IPT1
              CALL FPCOQ4(IVAPRE,IPMAIL,IPMINT,IVAFOR)
            ELSE IF (MELE.EQ.41.OR.MELE.EQ.56) THEN
              IPT1 = IPMAIL
              SEGACT, IPT1
              CALL FPCOQ8(IVAPRE,IPMAIL,IPMINT,IVACAR,IPMIN1,IVAFOR)
            ENDIF
          ELSE
C           ERREUR, ELEMENT NON IMPLEMENTE
            MOTERR(1:4)=NOMTP(MELE)
            MOTERR(5:12)='FEQPR '
            CALL ERREUR(86)
            GOTO 9990
          ENDIF
C
        ELSE IF (MFR2.EQ.13) THEN
C
C       - ELEMENTS TUYAU
C
           CALL FPELTU(IVAPRE,IVACAR,IPMAIL,I,IVAFOR)
C
C       - SINON TENTATIVE D'UTILISATION D'UNE OPTION NON IMPLEMENTEE
C
        ELSE
          CALL ERREUR(251)
          GOTO 9990
        ENDIF
C
C       DESACTIVATION AVANT DE PASSER A LA SOUS ZONE SUIVANTE
C
C
        IF(ISUP1.EQ.1)THEN
          CALL DTMVAL(IVASTR,3)
        ELSE
          CALL DTMVAL(IVASTR,1)
        ENDIF
C
        CALL DTMVAL(IVAFOR,1)
C
        IF(ISUP2.EQ.1)THEN
          CALL DTMVAL(IVAMAT,3)
          CALL DTMVAL(IVACAR,3)
        ELSE
          CALL DTMVAL(IVAMAT,1)
          CALL DTMVAL(IVACAR,1)
        ENDIF
C
        IF (IERR.NE.0) GO TO 9990
C
C=======================================================================
C
C       FIN DE BOUCLE SUR LES MODELES ELEMENTAIRES
C
C=======================================================================
  200 CONTINUE
C_______________________________________________________________________
C
C     TRANSFORMATION DU CHAMELEM EN CHPOINT
C_______________________________________________________________________
C
      CALL CHAMPO(IPCHE5,0,IPCHP4,IRETOU)
      CALL DTCHAM(IPCHE5)
      IF (IRETOU.EQ.0) GOTO 9000
C
C     FIN NORMALE
C
      IRET = 1
      GOTO 9000
C_______________________________________________________________________
C
C     ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
C_______________________________________________________________________
C
 9990 CONTINUE
      IF (MCHAML.NE.0) SEGSUP, MCHAML
      CALL DTMVAL(IVAFOR,3)
C
 9991 CONTINUE
C
 9992 CONTINUE
      IF (MCHELM.NE.0) SEGSUP, MCHELM
      IRET = 0
C_______________________________________________________________________
C
C     DERNIERES DESACTIVATION AVANT DE QUITTER
C_______________________________________________________________________
C
 9000 CONTINUE
      END
 
 
 
 
 
 
 
 

© Cast3M 2003 - Tous droits réservés.
Mentions légales