Sources Esope | Cast3M

pressi
C PRESSI    SOURCE    CB215821  24/04/12    21:16:55     11897          
      SUBROUTINE PRESSI
C_______________________________________________________________________
C
C                     OPERATEUR PRESSI
C
C-----------------------------------------------------------------------
C 1ere syntaxe : definition d'un CHPOINT de forces nodales equivalentes
C
C       FP = PRESSI I MASS MODEL I P MAIL I  (CARA)
C                                I CHPOT  I
C                                I CHAML I
C                   I COQU MODEL I P      I  I VECT I  (CARA)
C                                I CHPOT  I  I NORM I
C                                I CHAML I
C                   I FISS MODEL I P      I  VECT  POIN  CARA
C                                I CHPOT  I
C
C            FP        CHPOINT CONTENANT LES FORCES NODALES EQUIVALENTES
C            MODEL     OBJET MMODEL ,MASSIF ,COQUE OU FISS SUR LEQUEL
C                      S APPLIQUE LA PRESSION
C            P         VALEUR ALGEBRIQUE DE LA PRESSION
C            MAIL      POUR LES MASSIFS ,OBJET MAILLAGE REPRESENTANT
C                      LA FACE SUR LAQUELLE S'APPLIQUE LA PRESSION
C            CHPOT     CHPOINT CONTENANT LES VALEURS ALGEBRIQUES
C                      DES PRESSIONS AUX NOEUDS
C            VECT      POUR COQUE ET LINESPRING , VECTEUR INDIQUANT LA
C                      DIRECTION DANS LAQUELLE S APPLIQUE LA PRESSION
C            NORM      MOT CLE INDIQUANT QUE LA PRESSION EST POSITIVE
C                      SI ELLE EST PORTEE PAR LA NORMALE POSITIVE
C                      A L ELEMENT
C            CARA      POUR LES MASSIFS EN CONTRAINTES PLANES ET
C                      POUR LES COQUES EPAISSES, MCHAML CONTENANT
C                      LES VALEURS DES EPAISSEURS AUX POINTS
C                      D INTEGRATION
C            POIN      POUR LE LINESPRING , POINT OU SE RAPPORTE
C                      LE VECTEUR
C            CARA      POUR LE LINESPRING ,MCHAML CONTENANT LES VALEURS
C                      DES CARACTERISTIQUES AUX POINTS D INTEGRATION
C
C
C     MODIF EBERSOLT MAI 85 PRESSION SUR LES LEVRES DU LINESPRING
C
C     PASSAGE AUX NOUVEAU CHAMALEM PAR JM CAMPENON LE 04 08 90
C
C-----------------------------------------------------------------------
C 2e syntaxe : definition d'un MCHAML de pression
C
C       CHEL2  = PRES MOD1 | MOT1 VAL1 (MAIL1) ;
C                          | CHEL1
C
C            MOT1     NOM DE LA COMPOSANTE DE PRESSION
C            VAL1     VALEUR DE LA PRESSION
C            MAIL1    MAILLAGE DE LA SURFACE OU ON APPLIQUE LA PRESSION
C                     PAR DEFAUT, TOUTE LA SURFACE DE DEFINITION DU MODELE
C
C            CHAM1    MCHAML DE PRESSION DE NOM DE COMPOSANTE QUELCONQUE
C_______________________________________________________________________
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
-INC SMCHPOI
-INC SMCHAML
-INC SMMODEL
-INC SMCOORD
C
      PARAMETER  (NBTYP=5)
      CHARACTER*4 MTYPE(NBTYP),MNORM(1)
      CHARACTER*(4) MOSCAL,MOPOI1
      CHARACTER*(LOCHAI)   MOTLU
C
      DATA MTYPE/'MASS','COQU','FISS','TUYA','SHB8'/
      DATA MNORM/'NORM'/
      DATA MOSCAL/'SCAL'/,MOPOI1/'POI1'/
 
      MACRO,(MASSE,COQUE,FISSURE,TUYAU,COQUES_SHB8,SYNTAXE_2)
C
      segact mcoord
      IPMODL = 0
      IPCHE1 = 0
      IPCHM1 = 0
      IPCHE2 = 0
      IPCHA1 = 0
      ICONV  = 0
      IRET   = 0
 
C     ON LIT UN MOT CLE
      CALL LIRMOT(MTYPE,NBTYP,IMLU,0)
      IF(IERR.NE.0) RETURN
C     Si pas de mot-cle de la 1ere syntaxe, alors c'est la 2e
      IF(IMLU.EQ.0) THEN
        CALL LIRCHA(MOTLU,0,ILONG)
        IF(IERR.NE.0) RETURN
        IF(ILONG .EQ. 0) MOTLU =' '
        IMLU  =6
      ELSE
        MOTLU =MTYPE(IMLU)
      ENDIF
 
C     ON LIT UN MMODEL
      CALL LIROBJ('MMODEL ',IPMODL,1,IRETMO)
      IF(IERR.NE.0) RETURN
      CALL ACTOBJ('MMODEL ',IPMODL,1)
      IF(IERR.NE.0) RETURN
 
C      ON LIT UN CHAMP POINT (FACULTATIF)
      CALL LIROBJ('CHPOINT ',IPCHE1,0,IRETPO)
      IF(IERR.NE.0) RETURN
      IF(IRETPO .EQ. 1) CALL ACTOBJ('CHPOINT ',IPCHE1,1)
      IF(IERR.NE.0) RETURN
 
 
      CASE, IMLU
C----------------------------------------------------------------------
      WHEN, MASSE
C----------------------------------------------------------------------
C       ON LIT SOIT UN FLOTTANT ET UN MAILLAGE
C          SOIT UN CHPOINT  (IRETPO.NE.0)
C          SOIT UN CHAMELEM (IRETEL.NE.0)
C
        IPMAIL=0
        P=0.D0
        IF(IRETPO.EQ.0) THEN
           CALL LIROBJ('MCHAML  ',IPCHM1,0,IRETEL)
           IF(IERR.NE.0) RETURN
           IF(IRETEL.EQ.1) THEN
             CALL ACTOBJ('MCHAML  ',IPCHM1,1)
           ELSE
             IPCHM1 = 0
             CALL LIRREE(XXX,1,IRETOU)
             IF(IERR.NE.0) RETURN
             P=XXX
             CALL LIROBJ('MAILLAGE',IPMAIL,1,IRETMA)
             IF(IERR.NE.0) RETURN
             CALL ACTOBJ('MAILLAGE',IPMAIL,1)
             IF(IERR.NE.0) RETURN
           ENDIF
        ENDIF
C
        CALL FPMASS(IPCHE1,IPCHM1,IPMODL,IPTFP,IPMAIL,P,IRET)
        IF(IRET.EQ.0.OR.IERR.NE.0) RETURN
        GOTO 666
 
C----------------------------------------------------------------------
      WHEN, COQUE
C----------------------------------------------------------------------
C       ON LIT SOIT UN FLOTTANT
C          SOIT UN CHPOINT  (IRETPO.NE.0)
C          SOIT UN CHAMELEM (IRETEL.NE.0)
C
        P=0.D0
        IF(IRETPO.EQ.0) THEN
           CALL LIROBJ('MCHAML  ',IPCHM1,0,IRETEL)
           IF(IERR.NE.0) RETURN
           IF(IRETEL.EQ.1) THEN
             CALL ACTOBJ('MCHAML  ',IPCHM1,1)
           ELSE
             IPCHM1 = 0
             CALL LIRREE(XXX,1,IRETOU)
             IF(IERR.NE.0) RETURN
             P=XXX
             IPCHE1=0
           ENDIF
        ENDIF
C
C       ON LIT LE MOT CLE NORM SINON ON APPELERA PRORIE QUI
C       LIRA SES DONNEES
C
        CALL LIRMOT(MNORM,1,JMLU,0)
        IF(IERR.NE.0) RETURN
C
**      Comment je fais si je veux donner un vecteur?
**      IF(JMLU.EQ.0) THEN
**         CALL ERREUR(498)
**         IF(IERR.NE.0) RETURN
**         RETURN
**      ENDIF
C
C       LA LECTURE D'UN CHAMELEM DE CARACTERISTIQUE (FACULTATIVE
C       EST FAITE DANS FPCOQU
C
        CALL FPCOQU(P,IPCHE1,IPCHM1,IPMODL,JMLU,IPTFP,IRET,ICONV)
        IF(IRET.EQ.0 .OR. IERR.NE.0) RETURN
        GOTO 666
 
C----------------------------------------------------------------------
      WHEN, FISSURE
C----------------------------------------------------------------------
C       ON LIT SOIT UN FLOTTANT ,SOIT UN CHPOINT
C
        P=0.D0
        IF(IRETPO.EQ.0) THEN
          CALL LIRREE(XXX,1,IRETOU)
          IF(IERR.NE.0) RETURN
          P=XXX
          IPCHE1=0
        ENDIF
C
C       ON LIT UN VECTEUR
C
        CALL LIROBJ('POINT   ',IPVECT,1,IRETVC)
        IF(IERR.NE.0) RETURN
C
C       ON LIT UN POINT
C
        CALL LIROBJ('POINT   ',IPPOIN,1,IRETPT)
        IF(IERR.NE.0) RETURN
C
C       ON LIT UN CHELEM DE CARACTERISTIQUES
C
        CALL LIROBJ('MCHAML  ',IPCHE2,1,IRETCH)
        IF(IERR.NE.0) RETURN
        CALL ACTOBJ('MCHAML  ',IPCHE2,1)
        IF(IERR.NE.0) RETURN
C
        CALL FPFISS(P,IPCHE1,IPMODL,IPVECT,IPPOIN,IPCHE2,IPTFP,IRET)
        IF(IRET.EQ.0.OR.IERR.NE.0) RETURN
        GOTO 666
 
C----------------------------------------------------------------------
      WHEN, TUYAU
C----------------------------------------------------------------------
C       ON LIT UN OBJET CHAMELEM (CARACTERISTIQUES)
C
        CALL LIROBJ('MCHAML  ',IPCHE1,1,IRETC2)
        IF(IERR.NE.0) RETURN
        CALL ACTOBJ('MCHAML ',IPCHE1,1)
        IF(IERR.NE.0) RETURN
C
        CALL FPTUYA(IPMODL,IPCHE1,IPTFP,IRET)
        IF(IERR.NE.0.OR.IRET.NE.1)THEN
           RETURN
        ENDIF
        GOTO 666
 
C----------------------------------------------------------------------
      WHEN, COQUES_SHB8
C----------------------------------------------------------------------
C       ON LIT UN OBJET CHAMELEM (CARACTERISTIQUES)
C
        IPMAIL=0
        P=0.D0
        IF(IRETPO.EQ.0) THEN
          CALL LIRREE(XXX,1,IRETOU)
          IF(IERR.NE.0) RETURN
          P = XXX
        ENDIF
C
        CALL FPSHB8(IPMODL,IPCHE1,P,IPTFP)
        IF(IPTFP.EQ.0) RETURN
        GOTO 666
 
C----------------------------------------------------------------------
      WHEN, SYNTAXE_2
C----------------------------------------------------------------------C
C       On extrait du MMODEL la formulation CHARGEMENT PRESSSION
C       --------------------------------------------------------
        MMODEL = IPMODL
        NSOUS = KMODEL(/1)
        N1 = NSOUS
        SEGINI,MMODE1
        IMCGP=0
        DO isous = 1, NSOUS
          IMODEL = KMODEL(isous)
          IF(FORMOD(1).EQ.'CHARGEMENT      ') THEN
            NMAT = MATMOD(/2)
            CALL PLACE(MATMOD,NMAT,ipl,'PRESSION')
            IF(ipl.NE.0) THEN
              IMCGP = IMCGP + 1
              MMODE1.KMODEL(IMCGP) = IMODEL
            ENDIF
          ENDIF
        ENDDO
C
C       Si pas de modele chargement pression : erreur !
        IF(IMCGP.EQ.0) THEN
           MOTERR(1:16)='PRESSION        '
           CALL ERREUR(719)
           RETURN
        ELSE
           IPMODL=MMODE1
        ENDIF
C
C       Cas du MCHALM en argument
C       -------------------------
        IF(MOTLU.EQ.' ') THEN
          CALL LIROBJ('MCHAML  ',IPCHE1,1,IRET)
          IF(IERR.NE.0) RETURN
          CALL ACTOBJ('MCHAML  ',IPCHE1,1)
          IF(IERR.NE.0) RETURN
          CALL REDUAF(IPCHE1,IPMODL,IPCHE2,1,IRET,KERRE)
          IF(IERR.NE.0) RETURN
C
          IF(IRET.EQ.0) THEN
            CALL ERREUR(KERRE)
            RETURN
          ENDIF
          IPCHE1=IPCHE2
C
C         Y' plus qu'a :
          CALL PRCHL1(IPMODL,IPCHE1,IPCHE2)
          IF(IERR.NE.0) RETURN
C
          IF(IPCHE2.EQ.0) THEN
             CALL ERREUR(5)
             RETURN
          ENDIF
 
        ELSE
C         Cas avec MOT1, VAL1... en arguments
C         -----------------------------------
C
C         Lecture optionnelle d'un maillage
          CALL LIROBJ('MAILLAGE',IPGEO1,0,IRET)
          IF(IERR.NE.0) RETURN
C
C         Si un maillage est fourni, on reduit le modele sur le maillage
          IF(IRET.EQ.1) THEN
            CALL ACTOBJ('MAILLAGE',IPGEO1,1)
            CALL REDUMO(IPMODL,IPGEO1,IRET)
            IF(IERR.NE.0) RETURN
C
            IF(IRET.NE.0) THEN
               SEGSUP,MMODE1
               IPMODL=IRET
            ENDIF
          ENDIF
C
C         Lecture du FLOTTANT
          CALL LIRREE(XP1,1,IRET)
          IF(IERR.NE.0) RETURN
C
C         Sous-programme PRCHL2 : IPCHE2 contient le MCHAML resultat / 0 si echec
          CALL PRCHL2(IPMODL,MOTLU,XP1,IPCHE2)
          IF(IERR.NE.0) RETURN
C
          IF(IPCHE2.EQ.0) THEN
             CALL ERREUR(5)
             RETURN
          ENDIF
        ENDIF
 
        CALL ACTOBJ('MCHAML  ',IPCHE2,1)
        CALL ECROBJ('MCHAML  ',IPCHE2)
 
      ENDCASE
      RETURN
 
666   CONTINUE
C     LE NUMERO DE L HARMONIQUE EST PRIS EGAL A NIFOUR
C     POUR TOUTES LES COMPOSANTES DU CHPOINT
C
      MCHPOI = IPTFP
      NSOUPO = IPCHP(/1)
      NAT =JATTRI(/1)
      NAT2=MAX(NAT,1)
      IF(NAT .NE. NAT2)THEN
C       SEGADJ seulement si necessaire (reduit l'acces ESOPE)
        NAT=NAT2
        SEGADJ MCHPOI
      ENDIF
 
C     Le champ de force nodale est discret.
 
      JATTRI(1) = 2
      DO 100 IA=1,NSOUPO
        MSOUPO=IPCHP(IA)
        segact msoupo*mod
        DO 101 NC=1,NOHARM(/1)
          NOHARM(NC)=NIFOUR
101     CONTINUE
100   CONTINUE
 
      CALL ACTOBJ('CHPOINT  ',IPTFP,1)
      CALL ECROBJ('CHPOINT  ',IPTFP)
      END