Sources Esope | Cast3M

cli161
C CLI161    SOURCE    OF166741  24/12/13    21:15:22     12097          
      SUBROUTINE CLI161(MELEMF,MELEMC,MELECB,MELEFC,INORM,ICHPVO,ICHPSU,
     &     IROC,IVITC,IPC,IGAMC,ICHLIM,ICHRES,ICHRLI)
C************************************************************************
C
C PROJET            :  CASTEM 2000
C
C NOM               :  CLI161
C
C DESCRIPTION       :  Subroutine appellée par CLIM11
C
C LANGAGE           :  FORTRAN 77 + ESOPE 2000 (avec estensions CISI)
C
C AUTEUR            :  A. BECCANTINI, DRN/DMT/SEMT/LTMF
C
C************************************************************************
C
C APPELES (Calcul)  :
C
C************************************************************************
C
C HISTORIQUE (Anomalies et modifications éventuelles)
C
C HISTORIQUE :
C
C************************************************************************
C
      IMPLICIT INTEGER(I-N)
 
-INC PPARAM
-INC CCOPTIO
-INC SMLMOTS
-INC SMELEME
      POINTEUR MELEFC.MELEME
-INC SMLENTI
      POINTEUR MLEMC.MLENTI, MLEMCB.MLENTI,MLEMF.MLENTI
-INC SMCHPOI
      POINTEUR MPNORM.MPOVAL, MPVOL.MPOVAL, MPSURF.MPOVAL, MPRC.MPOVAL,
     &     MPVC.MPOVAL, MPPC.MPOVAL, MPGAMC.MPOVAL, MPLIM.MPOVAL,
     &     MPRES.MPOVAL,  MPRLI.MPOVAL
 
      INTEGER MELEMF,MELEMC,MELECB,INORM,ICHPVO,ICHPSU, IROC,IVITC,IPC
     &     ,IGAMC,ICHLIM,ICHRES,ICHRLI,ICEL,NFAC,IFAC
     &     ,NGF,NGC,NLF,NLC,NLCB
      REAL*8 VOLU,SURF,GAMC,CNX,CNY,CNZ,CTX,CTY,CTZ,GM1
     &     ,CT2X,CT2Y,CT2Z,RF,PF,UXF,UYF,UZF,UNF,UTF,UT2F
     &     ,UXC,UYC,UZC,RC,PC,UNC,UTC,UT2C
     &     ,HTF,SF,ECIN,PSRF,CELL(1),CELLT,FLUX2D(4),FLUX3D(5)
      CHARACTER*(8) TYPE
C
C
C**** KRIPAD pour la correspondance global/local
C
      CALL KRIPAD(MELEMC,MLEMC)
C     SEGINI MLEMC
      CALL KRIPAD(MELECB,MLEMCB)
C     SEGINI MLEMCB
      CALL KRIPAD(MELEMF,MLEMF)
C     SEGINI MLEMF
C
C**** CHPOINTs de la table DOMAINE
C
      CALL LICHT(INORM,MPNORM,TYPE,ICEL)
      CALL LICHT(ICHPVO,MPVOL,TYPE,ICEL)
      CALL LICHT(ICHPSU,MPSURF,TYPE,ICEL)
C
C**** LICHT active les MPOVALs en *MOD
C
C     SEGACT MPNORM*MOD
C     SEGACT MPOVSU*MOD
C     SEGACT MPOVOL*MOD
C
C
C**** CHPOINTs des variables
C
      CALL LICHT(IROC,MPRC,TYPE,ICEL)
      CALL LICHT(IVITC,MPVC,TYPE,ICEL)
      CALL LICHT(IPC,MPPC,TYPE,ICEL)
      CALL LICHT(IGAMC,MPGAMC,TYPE,ICEL)
      CALL LICHT(ICHLIM,MPLIM,TYPE,ICEL)
      CALL LICHT(ICHRES,MPRES,TYPE,ICEL)
      CALL LICHT(ICHRLI,MPRLI,TYPE,ICEL)
C
C     SEGACT *MOD
C     SEGACT *MOD
C     SEGACT *MOD
C     SEGACT *MOD
C     SEGACT *MOD
C     SEGACT *MOD
C     SEGACT *MOD
C
C
C**** Boucle sur le face pour le calcul des invariants de
C     Riemann et du flux
C
      SEGACT MELEFC
      NFAC=MELEFC.NUM(/2)
      UZC=0.0D0
      UZF=0.0D0
      UT2F=0.0D0
      CNZ=0.0D0
      CTZ=0.0D0
      CT2X=0.0D0
      CT2Y=0.0D0
      CT2Z=0.0D0
      DO IFAC=1,NFAC,1
         NGF=MELEFC.NUM(1,IFAC)
         NGC=MELEFC.NUM(2,IFAC)
         NLF=MLEMF.LECT(NGF)
         NLC=MLEMC.LECT(NGC)
         NLCB=MLEMCB.LECT(NGF)
         VOLU=MPVOL.VPOCHA(NLC,1)
         SURF=MPSURF.VPOCHA(NLF,1)
C        In CASTEM les normales sont sortantes
         CNX=-1*MPNORM.VPOCHA(NLF,1)
         CNY=-1*MPNORM.VPOCHA(NLF,2)
         IF(IDIM.EQ.2)THEN
            CTX=-1.0D0*CNY
            CTY=CNX
         ELSE
            CNZ=-1*MPNORM.VPOCHA(NLF,3)
            CTX=-1*MPNORM.VPOCHA(NLF,4)
            CTY=-1*MPNORM.VPOCHA(NLF,5)
            CTZ=-1*MPNORM.VPOCHA(NLF,6)
            CT2X=-1*MPNORM.VPOCHA(NLF,7)
            CT2Y=-1*MPNORM.VPOCHA(NLF,8)
            CT2Z=-1*MPNORM.VPOCHA(NLF,9)
         ENDIF
         GAMC=MPGAMC.VPOCHA(NLC,1)
         GM1=GAMC-1.0D0
C        Variables au centre
         RC=MPRC.VPOCHA(NLC,1)
         UXC=MPVC.VPOCHA(NLC,1)
         UYC=MPVC.VPOCHA(NLC,2)
         IF(IDIM.EQ.3) UZC=MPVC.VPOCHA(NLC,3)
         PC=MPPC.VPOCHA(NLC,1)
C        Variables à la face
         HTF=MPLIM.VPOCHA(NLCB,1)
         SF=MPLIM.VPOCHA(NLCB,2)
         UTF=0.0D0
C
C******* On calcule UNC
C
         UNC=(UXC*CNX)+(UYC*CNY)+(UZC*CNZ)
         UTC=(UXC*CTX)+(UYC*CTY)+(UZC*CTZ)
         UT2C=(UXC*CT2X)+(UYC*CT2Y)+(UZC*CT2Z)
         UNF=UNC
C
C******* On calcule UN, UT, UT2
C
         UXF=UNF*CNX+UTF*CTX+UT2F*CT2X
         UYF=UNF*CNY+UTF*CTY+UT2F*CT2Y
         UZF=UNF*CNZ+UTF*CTZ+UT2F*CT2Z
C
         ECIN=0.5D0*((UXF*UXF)+(UYF*UYF)+(UZF*UZF))
         PSRF=(GM1/GAMC)*(HTF-ECIN)
         RF=PSRF/SF
         if (rf.lt.0.d0) then
          call erreur(213)
          return
         endif
         RF=RF**(1.0D0/GM1)
         PF=SF*(RF**GAMC)
C
C******* Densite, vitesse, pression sur le bord
C
         MPRLI.VPOCHA(NLCB,1)=RF
         MPRLI.VPOCHA(NLCB,2)=UXF
         MPRLI.VPOCHA(NLCB,3)=UYF
         IF(IDIM.EQ.3) MPRLI.VPOCHA(NLCB,4)=UZF
         MPRLI.VPOCHA(NLCB,IDIM+2)=PF
C
         IF(IDIM.EQ.2)THEN
            CALL FAUSMP(0,
     &           GAMC,RF,PF,UNC,UTF,
     &           GAMC,RC,PC,UNC,UTC,
     &           CELL,CELL,
     &           FLUX2D,
     &           CELLT)
C
C******* Residuum (son SPG a le meme ordre que MELEFC)
C
            MPRES.VPOCHA(IFAC,1)=FLUX2D(1)*SURF/VOLU
            MPRES.VPOCHA(IFAC,2)=((FLUX2D(2)*CNX)+(FLUX2D(3)*CTX))
     &           *SURF/VOLU
            MPRES.VPOCHA(IFAC,3)=((FLUX2D(2)*CNY)+(FLUX2D(3)*CTY))
     &           *SURF/VOLU
            MPRES.VPOCHA(IFAC,4)=FLUX2D(4)*SURF/VOLU
         ELSE
            CALL FAUSM3(0,
     &           GAMC,RF,PF,UNC,UTF,UT2F,
     &           GAMC,RC,PC,UNC,UTC,UT2C,
     &           CELL,CELL,
     &           FLUX3D,
     &           CELLT)
C
C******* Residuum (son SPG a le meme ordre que MELEFC)
C
            MPRES.VPOCHA(IFAC,1)=FLUX3D(1)*SURF/VOLU
            MPRES.VPOCHA(IFAC,2)=((FLUX3D(2)*CNX)+(FLUX3D(3)*CTX)+
     &           (FLUX3D(4)*CT2X))*SURF/VOLU
            MPRES.VPOCHA(IFAC,3)=((FLUX3D(2)*CNY)+(FLUX3D(3)*CTY)+
     &           (FLUX3D(4)*CT2Y))*SURF/VOLU
            MPRES.VPOCHA(IFAC,4)=((FLUX3D(2)*CNZ)+(FLUX3D(3)*CTZ)+
     &           (FLUX3D(4)*CT2Z))*SURF/VOLU
            MPRES.VPOCHA(IFAC,5)=FLUX3D(5)*SURF/VOLU
         ENDIF
 
      ENDDO
C
C
      SEGSUP MLEMC
      SEGSUP MLEMCB
      SEGSUP MLEMF
C
 9999 CONTINUE
      END