Sources Esope | Cast3M

fpma1d
C FPMA1D    SOURCE    JK148537  24/11/05    21:15:02     12066          
 
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 PPARAM
-INC CCOPTIO
-INC CCREEL
-INC SMCHAML
-INC SMELEME
-INC SMINTE
-INC SMCOORD
 
C
      segment netn(nbpts+1)
      segment ietn(letn)
C
      SEGMENT WORK
        REAL*8 XE(3,NBNN)
      ENDSEGMENT
 
      SEGMENT MPTVAL
        INTEGER IPOS(NS),NSOF(NS),IVAL(NCOSOU)
        CHARACTER*16 TYVAL(NCOSOU)
      ENDSEGMENT
      real*8 v(1)
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                               &lt;- ACTIF en E/S
      NBPGAU=POIGAU(/1)
 
C
      idimp1 = IDIM +1
      netn = netn1
      ietn = ietn1
C
      ipt1 = ipmaim
      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
         xflot = 1d0
         if (netn1.ne.0) then
           do 160 inf=1,num(/1)
             ip=num(inf,ielt)
              id=netn(ip)+1
              if=netn(ip+1)
             do 165 itn=id,if
              iem=ietn(itn)
               jne=0
               do 166 i0=1,num(/1)
               do 166 i1=1,ipt1.num(/1)
                if (num(i0,ielt).eq.ipt1.num(i1,iem)) jne=jne+1
 166           continue
               if (jne.eq.num(/1)) goto 170
 165         continue
 160       continue
            CALL ERREUR(26)
C            IF(JPMAIL.EQ.0.AND.IPCHM1.EQ.0) CALL DTMODL(IPMOD1)
C            GOTO 9990
 170        CONTINUE
            NBM=IPT1.NUM(/1)
            NBMA1=NUM(/1)
              XG=0.D0
              DO INM=1,NBM
                IREFM=(IPT1.NUM(INM,IEM)-1)*idimp1
                XG=XG+XCOOR(IREFM+1)
              ENDDO
              XG=XG/NBM
              XK=0.D0
              DO INF=1,NBMA1
                IREFF=(NUM(INF,IEF)-1)*idimp1
                XK=XK+XCOOR(IREFF+1)
              ENDDO
              XK=XK/NBMA1
              V(1)=XG-XK
              VN=ABS(V(1))
              V(1)=V(1)/VN
         endif
         if (v(1).le.0d0) xflot =-1d0
        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*xflot
        ELSE
          T1=XP*T1*xflot
        ENDIF
        VELCHE(1,iElt)=VELCHE(1,iElt)+T1
      ENDDO
 
      SEGSUP,WORK
 
C*    SEGDES,MINTE                               &lt;- ACTIF en E/S
      SEGDES,MELEME
      IF (IPTVPR.NE.0) SEGDES,MELVA1
 
      RETURN
      END