Télécharger zfpu.eso

Retour à la liste

zfpu
C ZFPU      SOURCE    CB215821  20/11/25    13:44:53     10792          
      SUBROUTINE ZFPU(MTABX,MTAB1)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C***********************************************************************
C
C     SYNTAXE :
C
C        FPU  NU UET YP <,VPAROI>
C
C       1------2
C       (R1,AL1)  LEF   FLUIDE  NOEUDS 1 2
C
C
C     ANU     VISCOSITE CINEMATIQUE
C     UET     U*
C     YP      DISTANCE A LA PAROI
C     VPAROI  VITESSE DE LA PAROI (PAR DEFAUT 0.)
C
C   CAS TRIDIMENSIONNEL
C                       4 ________ 3
C                       / FLUIDE /
C                    1 /________/2
C
C
C***********************************************************************
 
-INC CCVQUA4
 
-INC PPARAM
-INC CCOPTIO
-INC SMCOORD
-INC SMLENTI
-INC SMELEME
      POINTEUR MELEM1.MELEME
-INC SMCHPOI
      POINTEUR IZG1.MCHPOI, IZGG1.MPOVAL
      POINTEUR IZD2.MCHPOI, IZDD2.MPOVAL
      POINTEUR IZD3.MCHPOI, IZDD3.MPOVAL
      POINTEUR IZTU1.MPOVAL,IZTU2.MPOVAL,IZTU3.MPOVAL
      POINTEUR MZNU.MPOVAL,MZUE.MPOVAL,MZYP.MPOVAL
      POINTEUR IZVOL.MPOVAL
 
-INC SMTABLE
      POINTEUR KIZG.TABLE,MTABX.MTABLE,OPTI.MTABLE
      POINTEUR INCO.TABLE,KOPT.MTABLE,KIZD.MTABLE
      POINTEUR MTABZ.MTABLE,MTABD.MTABLE
-INC SMLMOTS
      POINTEUR LINCO.MLMOTS
      CHARACTER*8 NOMZ,NOMI,NOMA,TYPE,CHAI,TYPC
      LOGICAL LOGI
      PARAMETER (NTB=1)
      CHARACTER*8 LTAB(NTB)
      DIMENSION KTAB(NTB),IXV(3)
      DATA LTAB/'KIZX    '/
C*****************************************************************************
CFPU
C     write(6,*)' debut FPU '
      CALL LEKTAB(MTAB1,'INCO',KINC)
      IF(KINC.EQ.0)THEN
      WRITE(6,*)' Opérateur NSKE :'
      WRITE(6,*)' Il n''y a pas de table INCO ? ?.'
      RETURN
      ENDIF
 
C*****************************************************************************
C OPTIONS
C CES PARAMETRES SONT INITIALISES POUR ETRE EN DECENTRE
      IKOMP=0
      IAXI=0
      IF(IFOMOD.EQ.0)IAXI=2
C     CALL LEKTAB(MTABX,'KOPT',OPTI)
      KOPTI=0
      TYPE=' '
      CALL ACMO(MTABX,'KOPT',TYPE,IENT)
      IF(TYPE.EQ.'TABLE')KOPTI=IENT
      IF(KOPTI.NE.0)THEN
      TYPE=' '
      CALL ACMO(KOPTI,'PRECAU',TYPE,IENT)
      IF(TYPE.EQ.'ENTIER')CALL ACME(KOPTI,'PRECAU',IPRE)
      TYPE=' '
      CALL ACMO(KOPTI,'IKOMP',TYPE,IENT)
      IF(TYPE.EQ.'ENTIER')CALL ACME(KOPTI,'IKOMP',IKOMP)
 
      ENDIF
C*****************************************************************************
 
      CALL ACMM(MTABX,'NOMZONE',NOMZ)
      CALL LEKTAB(MTABX,'DOMZ',MTABZ)
      IF(MTABZ.EQ.0)THEN
      WRITE(6,*)' On ne trouve pas l''indice DOMZ ? '
      GO TO 90
      ENDIF
      SEGACT MTABZ
 
      CALL LEKTAB(MTABZ,'MAILLAGE',MELEME)
      IF(MELEME.EQ.0)GO TO 90
      SEGACT MELEME
 
      CALL LEKTAB(MTABZ,'CENTRE',MELEMC)
      IF(MELEMC.EQ.0)GO TO 90
 
      CALL LEKTAB(MTABZ,'XXVOLUM',MCHPOI)
      IF(MCHPOI.EQ.0)GO TO 90
      CALL LICHT(MCHPOI,IZVOL,TYPC,IGEOM)
C***
 
      TYPE='LISTMOTS'
      CALL ACMO(MTABX,'LISTINCO',TYPE,LINCO)
      SEGACT LINCO
 
      CALL ACME(MTABX,'IARG',IARG)
      IKOMP=0
 
C--Cas incompréssible
      IF(IKOMP.EQ.0)THEN
C 1er coefficient : nu
      IXV(1)=MELEMC
      IXV(2)=1
      IXV(3)=0
      IRET  =0
      CALL LEKCOF('Opérateur FPU :',
     & MTABX,KINC,1,IXV,MNU,MZNU,NPT1,NC1,IK1,IRET)
      IF(IRET.EQ.0)RETURN
 
C 2ème coefficient : uet
      IXV(1)=MELEMC
      IXV(2)=0
      IXV(3)=0
      IRET  =0
      CALL LEKCOF('Opérateur FPU :',
     & MTABX,KINC,2,IXV,MUE,MZUE,NPT2,NC2,IK2,IRET)
      IF(IRET.EQ.0)RETURN
 
C 3ème coefficient : yp
      IXV(1)=0
      IXV(2)=1
      IXV(3)=0
      IRET  =0
      CALL LEKCOF('Opérateur FPU :',
     & MTABX,KINC,3,IXV,MYP,MZYP,NPT3,NC3,IK3,IRET)
      IF(IRET.EQ.0)RETURN
 
 
 
 
 
 
 
 
C--Cas compréssible
      ELSEIF(IKOMP.EQ.1)THEN
C 1er coefficient : mu
      IXV(1)=MELEMC
      IXV(2)=1
      IXV(3)=0
      CALL LEKCOF('Opérateur FPU :',
     & MTABX,KINC,1,IXV,MNU,MZNU,NPT1,NC1,IK1,IRET)
      IF(IRET.EQ.0)RETURN
 
C 2ème coefficient : uet
      IXV(1)=MELEMC
      IXV(2)=0
      IXV(3)=0
      CALL LEKCOF('Opérateur FPU :',
     & MTABX,KINC,2,IXV,MUE,MZUE,NPT2,NC2,IK2,IRET)
      IF(IRET.EQ.0)RETURN
 
      ENDIF
 
      CALL LEKTAB(MTABX,'EQEX',MTAB1)
      IF(MTAB1.EQ.0)THEN
      WRITE(6,*)' On ne trouve pas l''indice EQEX ? '
      GO TO 90
      ENDIF
      SEGACT MTAB1
      CALL LEKTAB(MTAB1,'DOMAINE',MTABD)
      IF(MTABD.EQ.0)THEN
      WRITE(6,*)' On ne trouve pas l''indice DOMAINE ?'
      GO TO 90
      ENDIF
      SEGACT MTABD
      CALL LEKTAB(MTABD,'SOMMET',MELEM1)
      IF(MELEM1.EQ.0)THEN
      WRITE(6,*)' On ne trouve pas l''indice SOMMET ?'
      GO TO 90
      ENDIF
 
      CALL LEKTAB(MTAB1,'INCO',INCO)
      IF(INCO.EQ.0)THEN
      WRITE(6,*)'Il n''y a pas de table INCO '
      RETURN
      ENDIF
      SEGACT INCO
 
      CALL LEKTAB(MTAB1,'KIZD',KIZD)
      IF(KIZD.EQ.0)THEN
      WRITE(6,*)'Il n''y a pas de table KIZD '
      RETURN
      ENDIF
      SEGACT KIZD
 
      CALL KRIPAD(MELEM1,MLENTI)
 
C*****************************************************************************
 
      CALL LEKTAB(MTAB1,'KIZG',KIZG)
      IF(KIZG.EQ.0)THEN
      CALL CRTABL(KIZG)
      CALL ECMM(KIZG,'SOUSTYPE','KIZG')
      CALL ECMO(MTAB1,'KIZG','TABLE   ',KIZG)
      ELSE
      SEGACT KIZG
      ENDIF
 
C VERIFICATIONS SUR LES INCONNUES
      NBINC=LINCO.MOTS(/2)
      IF(NBINC.NE.3)THEN
      WRITE(6,*)'Nombre d''inconnues incorrecte : ',NBINC,' On attend 3'
      RETURN
      ENDIF
 
C --> 1 ere Inconnue
 
      NOMI=LINCO.MOTS(1)
 
      TYPE=' '
      CALL ACMO(INCO,NOMI,TYPE,MCHPOI)
      IF(TYPE.NE.'CHPOINT ')THEN
      WRITE(6,*)' L objet CHPOINT ',NOMI,' n existe pas dans la table'
      RETURN
      ELSE
      CALL LICHT(MCHPOI,IZTU1,TYPC,IGEOM0)
      ENDIF
 
      TYPE=' '
      CALL ACMO(KIZG,NOMI,TYPE,IZG1)
      IF(TYPE.NE.'CHPOINT ')THEN
      NC=IZTU1.VPOCHA(/2)
      TYPE='SOMMET'
      CALL CRCHPT(TYPE,IGEOM0,NC,IZG1)
      CALL ECMO(KIZG,NOMI,'CHPOINT ',IZG1)
      ENDIF
 
      CALL LICHT(IZG1,IZGG1,TYPC,IGEOM)
 
C --> 2 eme Inconnue
 
      NOMI=LINCO.MOTS(2)
 
      TYPE=' '
      CALL ACMO(INCO,NOMI,TYPE,MCHPOI)
      IF(TYPE.NE.'CHPOINT ')THEN
      WRITE(6,*)' L objet CHPOINT ',NOMI,' n existe pas dans la table'
      RETURN
      ELSE
      CALL LICHT(MCHPOI,IZTU2,TYPC,IGEOM0)
      ENDIF
 
      TYPE=' '
      CALL ACMO(KIZD,NOMI,TYPE,IZD2)
      IF(TYPE.NE.'CHPOINT ')THEN
      WRITE(6,*)' Il n''y a pas de diagonale associee a ',NOMI
      RETURN
      ENDIF
 
      CALL LICHT(IZD2,IZDD2,TYPC,IGEOM)
 
C --> 3 eme Inconnue
 
      NOMI=LINCO.MOTS(3)
 
      TYPE=' '
      CALL ACMO(INCO,NOMI,TYPE,MCHPOI)
      IF(TYPE.NE.'CHPOINT ')THEN
      WRITE(6,*)' L objet CHPOINT ',NOMI,' n existe pas dans la table'
      RETURN
      ELSE
      CALL LICHT(MCHPOI,IZTU3,TYPC,IGEOM0)
      ENDIF
 
      TYPE=' '
      CALL ACMO(KIZD,NOMI,TYPE,IZD3)
      IF(TYPE.NE.'CHPOINT ')THEN
      WRITE(6,*)' Il n''y a pas de diagonale associee a ',NOMI
      RETURN
      ENDIF
 
      CALL LICHT(IZD3,IZDD3,TYPC,IGEOM)
 
 
      SEGACT MELEME
      NBSOUS=LISOUS(/1)
      IF(NBSOUS.EQ.0)NBSOUS=1
      NUTOEL=0
 
      NPTD=IZTU1.VPOCHA(/1)
      IES=IDIM
 
      DO 1 L=1,NBSOUS
      IPT1=MELEME
      IF(NBSOUS.NE.1)IPT1=LISOUS(L)
      SEGACT IPT1
 
      NP  =IPT1.NUM(/1)
      NBEL=IPT1.NUM(/2)
 
C SUBROUTINE XCVFPU(NEL,K0,NP,IES,IAXI,IPADL,
C    & LEF,XYZ,               ----> IPT1,COOR
C    & VOLF,                  ----> IZVOL.T,
C    & UN,TK,TE,              ----> IZTU1.T,IZTU2.T,IZTU3.T,
C    & F,                     ----> IZG1,
C    & DK,DE,                 ----> IZD2,IZD3
C    & ANU,IKC,UET,YP,        ----> IZTG1.T,IK1,IZTG2.T,IZTG3.T,
C    & VPAROI,IKV,                  IZTG4.T,IK4,
C    & PORO,NPR,IPOR)         ----> IZPORO,NPOR,IOP7
 
C     write(6,*)' Appel YCVFPU '
      CALL ZCVFPU(NBEL,NUTOEL,NP,IES,NPTD,IAXI,LECT,
     & IPT1.NUM,XCOOR,
     & IZVOL.VPOCHA,
     & IZTU1.VPOCHA,IZTU2.VPOCHA,IZTU3.VPOCHA,
     & IZGG1.VPOCHA,
     & IZDD2.VPOCHA,IZDD3.VPOCHA,
     & MZNU.VPOCHA,IK1,MZUE.VPOCHA,MZYP.VPOCHA)
 
      SEGDES IPT1
      NUTOEL=NUTOEL+NBEL
 
 1    CONTINUE
 
 
      SEGDES IZTU1,IZTU2,IZTU3
      SEGDES IZG1,IZGG1
      SEGDES IZD2,IZDD2
      SEGDES IZD3,IZDD3
      SEGDES IZVOL
      SEGDES LINCO
      SEGDES MTABX,MTAB1,INCO,KIZG,KIZD
      SEGSUP MLENTI
 
      RETURN
 90   CONTINUE
      WRITE(6,*)' Interuption anormale de FPU '
      RETURN
 1002 FORMAT(10(1X,1PE11.4))
      END
 
 
 
 
 
 

© Cast3M 2003 - Tous droits réservés.
Mentions légales