Sources Esope | Cast3M

fptuya
C FPTUYA    SOURCE    CB215821  24/04/12    21:16:03     11897          
      SUBROUTINE FPTUYA(IPMODL,IPCHE1,IPTFP,IRET)
C____________________________________________________________________
C
C   CALCULE LES FORCES DE PRESSIONS APPLIQUEES SUR DES TUYAUX
C    ( EFFET DE FOND ) APPELE PAR PRESSI
C
C
C   ENTREES :
C   ---------
C
C       IPCHE1   POINTEUR SUR UN MCHAML DE CARACTERISTIQUES
C       IPMODL   POINTEUR SUR UN MMODEL
C
C  SORTIES
C
C
C       IPTFP    CHPOINT DES FORCES NODALES EQUIVALENTES
C       IRET     1 OU 0 SI SUCCES OU NON
C
C     M. PETIT NOVEMBRE 89
C     PASSAGE AUX NOUVEAU CHAMELEM PAR JM CAMPENON LE 04 09 90
C
C_____________________________________________________________________
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
C
 
-INC PPARAM
-INC CCOPTIO
-INC CCREEL
-INC SMCOORD
-INC SMELEME
-INC SMMODEL
-INC SMCHAML
-INC SMINTE
*
      SEGMENT NOTYPE
        CHARACTER*16 TYPE(NBTYPE)
      ENDSEGMENT
C
      SEGMENT MPTVAL
        INTEGER IPOS(NS)    ,NSOF(NS)
        INTEGER      IVAL(NCOSOU)
        CHARACTER*16 TYVAL(NCOSOU)
      ENDSEGMENT
C
      CHARACTER*8 CMATE
      CHARACTER*(NCONCH) CONM
      PARAMETER ( NINF=3 )
      INTEGER INFOS(NINF)
      LOGICAL lsupfo
C
      IRET = 0
C
      NHRM=NIFOUR
C
C     VERIFICATION DU LIEU SUPPORT DU MCHAML DE CARACTERISTIQUE
C
      CALL QUESUP (IPMODL,IPCHE1,3,0,ISUP,IRETCA)
      IF (ISUP.GT.1) RETURN
C
C     ACTIVATION DU MODELE
C
      MMODEL=IPMODL
      SEGACT MMODEL
      NSOUS=KMODEL(/1)
C
C     CREATION D UN MCHELM INTERMEDIAIRE
C
      N1=NSOUS
      L1=5
      N3=5
      SEGINI MCHELM
      ICHAM=MCHELM
      TITCHE='FORCE'
      IFOCHE=IFOUR
C
C     DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES
C
      DO 101 ISOUS=1,NSOUS
C
C     ON RECUPERE L INFORMATION GENERALE
C
         IMODEL=KMODEL(ISOUS)
         SEGACT IMODEL
         IPMAIL=IMAMOD
         CONM  =CONMOD
         IMACHE(ISOUS)=IPMAIL
         CONCHE(ISOUS)=CONMOD
C
C        TRAITEMENT DU MODELE
C
         MELE=NEFMOD
         MELEME=IMAMOD
C
C        INFORMATION SUR L'ELEMENT FINI
C
*         CALL ELQUOI(MELE,0,3,IPINF,IMODEL)
*         IF (IERR.NE.0) THEN
*           SEGSUP MCHELM
*           RETURN
*         ENDIF
*         INFO=IPINF
         MFR  =INFELE(13)
         IF (MFR.EQ.13) GOTO 102
C
*         SEGSUP INFO
         SEGSUP MCHELM
         CALL ERREUR(16)
         RETURN
C
C        ON A BIEN DES ELEMENTS TUYA
C
* 102     MINTE=INFELE(11)
 102     MINTE=INFMOD(5)
         IPMINT=MINTE
*            SEGSUP INFO
C
C        CREATION DU TABLEAU INFOS
C
         CALL IDENT(IPMAIL,CONM,IPCHE1,0,INFOS,IRTD)
         IF (IRTD.EQ.0) THEN
            SEGSUP MCHELM
            RETURN
         ENDIF
C
         INFCHE(ISOUS,1)=0
         INFCHE(ISOUS,2)=0
         INFCHE(ISOUS,3)=NHRM
         INFCHE(ISOUS,4)=MINTE
         INFCHE(ISOUS,5)=0
C
C        ACTIVATION DU MELEME
C
         SEGACT MELEME
         NBNN  =NUM(/1)
         NBELEM=NUM(/2)
         IPPORE=0
         IF(MFR.EQ.33) IPPORE=NBNN
C
C        RECHERCHE DES NOMS DE COMPOSANTES
C
        if(lnomid(2).ne.0) then
          nomid=lnomid(2)
          segact nomid
          moforc=nomid
          nfor=lesobl(/2)
          nfac=0
          lsupfo=.false.
        else
         lsupfo=.true.
         CALL IDFORC(MFR,IFOUR,MOFORC,NFOR,NFAC)
        endif
C
C        TAILLE DES MELVAL A ALLOUER
C
         N1PTEL=2
         N1EL=NBELEM
         N2PTEL=0
         N2EL=0
C
C        CREATION DU MCHAML DE LA SOUS ZONE
C
         N2=NFOR
         SEGINI MCHAML
         ICHAML(ISOUS)=MCHAML
         NS=1
         NCOSOU=NFOR
         SEGINI MPTVAL
         IVAFOR=MPTVAL
         NOMID=MOFORC
         SEGACT NOMID
         DO 1 ICOMP=1,NFOR
            NOMCHE(ICOMP)=LESOBL(ICOMP)
            TYPCHE(ICOMP)='REAL*8'
            SEGINI MELVAL
            IELVAL(ICOMP)=MELVAL
            IVAL(ICOMP)=MELVAL
 1       CONTINUE
C
C        TRAITEMENT DES CHAMPS DE CARACTERISTIQUES
C
         NBROBL=0
         NBRFAC=0
         MOCARA=0
         NCARA=0
         NCARF=0
         NCARR=0
C
C        CARACTERISTIQUES POUR LES TUYAUX
C
         NBROBL=3
         NBRFAC=4
         SEGINI NOMID
         MOCARA=NOMID
         LESOBL(1)='EPAI'
         LESOBL(2)='RAYO'
         LESOBL(3)='PRES'
         LESFAC(1)='RACO'
         LESFAC(2)='VX'
         LESFAC(3)='VY'
         LESFAC(4)='VZ'
*
         NBTYPE=7
         SEGINI NOTYPE
         MOTYPE=NOTYPE
         TYPE(1)='REAL*8'
         TYPE(2)='REAL*8'
         TYPE(3)='REAL*8'
         TYPE(4)='REAL*8'
         TYPE(5)='REAL*8'
         TYPE(6)='REAL*8'
         TYPE(7)='REAL*8'
C
         CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3,IVACAR)
         SEGSUP NOTYPE
         IF (IERR.NE.0) GOTO 9990
         MPTVAL=IVACAR
         NCARA=NBROBL
         NCARF=NBRFAC
         NCARR=NCARA+NCARF
C
         IF (ISUP.EQ.1) THEN
            MINTE=IPMINT
            SEGACT,MINTE
            CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE,MOCARA,MELE)
            IF(IERR.NE.0)THEN
               ISUP=0
               GOTO 9990
            ENDIF
         ENDIF
C
C        CALCUL DES FORCES DE PRESSION
C
         CALL FPELTU(0,IVACAR,IPMAIL,ISOUS,IVAFOR)
C
C
         NOMID=MOCARA
         IF (MOCARA.NE.0) SEGSUP NOMID
         IF (ISUP.EQ.1) THEN
           CALL DTMVAL(IVACAR,3)
         ELSE
           CALL DTMVAL(IVACAR,1)
         ENDIF
C
         NOMID=MOFORC
         if(lsupfo)SEGSUP NOMID
         CALL DTMVAL(IVAFOR,1)
C
C
 101  CONTINUE
      IRET = 1
      CALL CHAMPO(ICHAM,0,IPTFP,IRET)
      CALL DTCHAM(ICHAM)
      RETURN
C
 9990 CONTINUE
      IRET=0
C
C     ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
C
      NOMID=MOCARA
      IF (MOCARA.NE.0) SEGSUP NOMID
      IF (ISUP.EQ.1) THEN
        CALL DTMVAL(IVACAR,3)
      ELSE
        CALL DTMVAL(IVACAR,1)
      ENDIF
C
      NOMID=MOFORC
      if(lsupfo)SEGSUP NOMID
      CALL DTMVAL(IVAFOR,1)
C
      SEGSUP MCHELM
 
      END