C FPMA1D    SOURCE    FANDEUR   10/08/31    21:17:10     6734           

C=======================================================================
C=  Calcul des forces de pressions s'exercant sur les faces d elements =
C=  massifs unidimensionnels (1D)                                      =
C=                                                                     =
C=  IPTVPR  Pointeur sur un MELVAL contenant les pressions appliquees  =
C=          =0 si on a donne une valeur constante                      =
C=  IPMAIL  Pointeur sur un MELEME de l'ENVELOPPE                      =
C=  IPTINT  Pointeur sur un MINTE des caracteristiques d'integration   =
C=          (ACTIF en ENTREE et en SORTIE sans modification)           =
C=  IVAFOR  Pointeur sur un MPTVAL (MELVAL) contenant les forces       =
C=          nodales equivalentes                                       =
C=  XP      Valeur de la pression si constante                         =
C=======================================================================

      SUBROUTINE FPMA1D (IPTVPR,IPMAIL,IPTINT,IVAFOR,XP)

      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)

-INC CCOPTIO
-INC CCREEL
-INC SMCHAML
-INC SMELEME
-INC SMINTE
-INC SMCOORD

      SEGMENT WORK
        REAL*8 XE(3,NBNN)
      ENDSEGMENT

      SEGMENT MPTVAL
        INTEGER IPOS(NS),NSOF(NS),IVAL(NCOSOU)
        CHARACTER*16 TYVAL(NCOSOU)
      ENDSEGMENT

C= Quelques constantes (2.Pi et 4.Pi)
      PARAMETER (X2Pi=6.283185307179586476925286766559D0)
      PARAMETER (X4Pi=12.566370614359172953850573533118D0)

      IF (IPTVPR.NE.0) THEN
        MELVA1=IPTVPR
        SEGACT,MELVA1
        IVA12=MELVA1.VELCHE(/2)
      ENDIF

      MINTE=IPTINT
C*    SEGACT,MINTE                               <- ACTIF en E/S
      NBPGAU=POIGAU(/1)

      MELEME=IPMAIL
      SEGACT,MELEME
      NBNN=NUM(/1)
      NBELEM=NUM(/2)

C*OF  IF ((NBPGAU.NE.1).OR.(NBNN.NE.1)) THEN
C*OF    WRITE(6,*) 'ERREUR FATALE : FPMA1D'
C*OF    RETURN
C*OF  ENDIF

      SEGINI,WORK

      MPTVAL=IVAFOR
      MELVAL=IVAL(1)
C= BOUCLE SUR LES ELEMENTS
      DO iElt=1,NBELEM
        CALL DOXE(XCOOR,IDIM,NBNN,NUM,iElt,XE)
C= Cas des elements AXISymetriques et SPHEriques
        IF (IFOUR.GE.12.AND.IFOUR.LE.14) THEN
          T1=X2Pi*XE(1,1)
        ELSE IF (IFOUR.EQ.15) THEN
          RR=XE(1,1)
          T1=X4Pi*RR*RR
        ELSE
          T1=1.
        ENDIF
        IF (IPTVPR.NE.0) THEN
          IEMN=MIN(iElt,IVA12)
          T1=MELVA1.VELCHE(1,IEMN)*T1
        ELSE
          T1=XP*T1
        ENDIF
        VELCHE(1,iElt)=VELCHE(1,iElt)+T1
      ENDDO

      SEGSUP,WORK

C*    SEGDES,MINTE                               <- ACTIF en E/S
      SEGDES,MELEME
      IF (IPTVPR.NE.0) SEGDES,MELVA1

      RETURN
      END