Sources Esope | Cast3M

fpma1d
C FPMA1D    SOURCE    OF166741  25/02/06    21:15:03     12146          
 
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
 
      segment netn(notn)
      segment ietn(letn)
 
      SEGMENT WORK
        REAL*8 XE(3,NBNN)
      ENDSEGMENT
 
      SEGMENT MPTVAL
        INTEGER IPOS(NS),NSOF(NS)
        INTEGER      IVAL(NCOSOU)
        CHARACTER*16 TYVAL(NCOSOU)
      ENDSEGMENT
 
      idimp1 = IDIM+1
*   prob optimiseur il faut initialiser melva1
      melva1 = IPTINT
      IF (IPTVPR.NE.0) THEN
        MELVA1=IPTVPR
c*        SEGACT,MELVA1                            &lt;- ACTIF EN E/S
c*        IVA11=MELVA1.VELCHE(/1)
        IVA12=MELVA1.VELCHE(/2)
      ENDIF
 
      MINTE=IPTINT
C*      SEGACT,MINTE                               &lt;- ACTIF EN E/S
      NBPGAU=POIGAU(/1)
 
      MELEME=IPMAIL
c*      SEGACT,MELEME                              &lt;- 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                                &lt;- 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                               &lt;- ACTIF en E/S
c*      SEGDES,MELEME                              &lt;- ACTIF en E/S
c*      IF (IPTVPR.NE.0) SEGDES,MELVA1             &lt;- ACTIF en E/S
 
      RETURN
      END