C FPMA1D    SOURCE    OF166741  25/02/21    21:16:41     12166          

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,IPMAIM,IPTINT,IVAFOR,XP
     &                 ,netn1,ietn1)

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

-INC PPARAM
-INC CCOPTIO
-INC CCREEL
C= Quelques constantes (2.Pi et 4.Pi)
      PARAMETER (X2Pi=6.283185307179586476925286766559D0)
      PARAMETER (X4Pi=12.566370614359172953850573533118D0)

-INC SMCHAML
-INC SMELEME
-INC SMINTE
-INC SMCOORD

-INC TMPTVAL

      segment netn(notn)
      segment ietn(letn)

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

      idimp1 = IDIM+1
*   prob optimiseur il faut initialiser melva1
      melva1 = IPTINT
      IF (IPTVPR.NE.0) THEN
        MELVA1=IPTVPR
c*        SEGACT,MELVA1                            <- ACTIF EN E/S
c*        IVA11=MELVA1.VELCHE(/1)
        IVA12=MELVA1.VELCHE(/2)
      ENDIF

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

      MELEME=IPMAIL
c*      SEGACT,MELEME                              <- ACTIF EN E/S
      NBNN   = meleme.NUM(/1)
      NBELEM = meleme.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

      netn = netn1
      ietn = ietn1
      IPT1 = IPMAIM

      IF (IPT1.GT.0) THEN
        if (netn.eq.0 .or. ietn.eq.0) then
          write(ioimp,*) 'FPMA1D : incompatibilite netn, ietn & IPMAIM'
        endif
c*        SEGACT,IPT1                                <- ACTIF en E/S
        NBNN1 = ipt1.NUM(/1)
        NBEL1 = ipt1.NUM(/2)
      ELSE
        if (netn.gt.0 .or. ietn.gt.0) then
          write(ioimp,*) 'FPMA1D : incompatibilite netn, ietn & IPMAIM'
        endif
      ENDIF

      MPTVAL=IVAFOR
      MELVAL=IVAL(1)

C= BOUCLE SUR LES ELEMENTS
      DO iElt = 1, NBELEM

        CALL DOXE(XCOOR,IDIM,NBNN,NUM,iElt,XE)

        XFLOT = +1.D0
        IF (netn.GT.0) THEN
          DO inf = 1, nbnn
            ip = meleme.num(inf,ielt)
            ideb = netn(ip)+1
            ifin = netn(ip+1)
            do itn = ideb, ifin
              IEM = ietn(itn)
              jne = 0
              do i = 1, nbnn
                ino = num(i,ielt)
                do i1 = 1, nbnn1
                  if (ino.eq.ipt1.num(i1,IEM)) jne=jne+1
                enddo
              enddo
              if (jne.eq.nbnn) goto 170
            enddo
          ENDDO
          CALL ERREUR(26)
          GOTO 9900
 170      continue
          XG = 0.D0
          DO I = 1, NBNN1
            ino = (IPT1.NUM(I,IEM)-1)*idimp1
            XG=XG+XCOOR(ino+1)
          ENDDO
          XG=XG / NBNN1

          XK=0.D0
          DO i = 1,NBNN
            XK=XK+XE(1,I)
          ENDDO
          XK=XK/NBNN

          V_1 = XG - XK
          r_z = 1.D0 / ABS(V_1)
          V_1 = V_1 * r_z

          if (v_1.lt.0d0) XFLOT = -1.d0
        ENDIF

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.D0
        ENDIF
        IF (IPTVPR.NE.0) THEN
          IEMN=MIN(iElt,IVA12)
          T1=MELVA1.VELCHE(1,IEMN)*T1*xflot
        ELSE
          T1=XP*T1*xflot
        ENDIF
        VELCHE(1,iElt)=VELCHE(1,iElt)+T1
      ENDDO

 9900 CONTINUE
      SEGSUP,WORK

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

      RETURN
      END