Sources Esope | Cast3M

prijac
C PRIJAC    SOURCE    CB215821  20/11/25    13:36:52     10792          
      SUBROUTINE PRIJAC
C************************************************************************
C
C PROJET            :  CASTEM 2000
C
C NOM               :  PRIJAC
C
C DESCRIPTION       :  Subroutine appellée par PRIMIT
C
C                      Modelisation 2D/3D des equations d'Euler
C
C                      Calcul du jacobien dCONS/dPRIM
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)  :  PRIJA1, PRIJA2
C
C************************************************************************
C
C*** SYNTAXE
C
C  Discrétisation en VF "cell-centered" des équations d'Euler pour
C  un gaz parfait mono-constituent polytropique
C
C  RMAT1 = 'PRIM' 'CONSPRIM' MAIL1 LMOT1 LMOT2
C          CHPO1 CHPO2 CHPO3 CHPO4 ;
C
C  ENTREES
C
C  LMOT1   : objet de type LISTMOTS
C           Noms de composantes des variable duales de RMAT1.
C           Il contient dans l'ordre suivant: le noms de la densité,
C           du momentum, de l'énergie totale par unité de volume
C
C  LMOT2   : objet de type LISTMOTS
C           Noms de composantes des variable primales de RMAT1.
C           Il contient dans l'ordre suivant: le noms de la densité,
C           de la vitesse, de la pression.
C
C  MAIL1  : SPG des CHPOINTS
C
C  CHPO1  : CHPOINT contenant la masse volumique
C           (une seule composante, 'SCAL').
C
C  CHPO2  : CHPOINT contenant la vitesse
C           (deux/trois composantes
C           'UX', 'UY', 'UZ')
C
C  CHPO3  : CHPOINT contenant la pression du gaz
C           (une seule composante,
C            'SCAL').
C
C  CHPO4  : CHPOINT contenant le "gamma" du gaz
C           (une seule composante,
C            'SCAL').
C
C SORTIES
C
C  RMAT1  : objet de type MATRIK
C          (SPG =  TAB1 . 'CENTRE')
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 SMCHPOI
-INC SMELEME
      POINTEUR MLMVIT.MLMOTS
C
C**** Variables de COOPTIO
C
C      INTEGER IPLLB, IERPER, IERMAX, IERR, INTERR
C     &        ,IOTER,   IOLEC,  IOIMP,     IOCAR,  IOACQ
C     &        ,IOPER,   IOSGB,  IOGRA,     IOSAU,  IORES
C     &        ,IECHO,   IIMPI,  IOSPI
C     &        ,IDIM,    IFICLE, IPREFI
C     &        ,MCOORD
C     &        ,IFOMOD, NIFOUR, IFOUR, NSDPGE, IONIVE
C     &        ,NGMAXY, IZROSF, ISOTYP, IOSCR,LTEXLU
C     &        ,NORINC,NORVAL,NORIND,NORVAD
C     &        ,NUCROU, IPSAUV
C
      INTEGER IRET, INDIC, NBCOMP, NESP, JGN, JGM
     &     ,MELEMC
     &     ,IJACO, ILIINC, ILIINP, NC
     &     ,IRN, IVN, IPN, IGAMN
C
      CHARACTER*8 TYPE
      CHARACTER*4 MOT
      CHARACTER*(40) MESERR
C
C*********************
C**** Le SPG *********
C*********************
C
      TYPE='MAILLAGE'
      CALL LIROBJ(TYPE,MELEMC,1,IRET)
      IF(IERR .NE. 0)GOTO 9999
C
      NESP=0
C
C**** La list des inconnues duales (variables conservatives)
C
      TYPE='LISTMOTS'
      CALL LIROBJ(TYPE,ILIINC,1,IRET)
      IF(IERR .NE. 0) GOTO 9999
      MLMOTS = ILIINC
      SEGACT MLMOTS
      NC = MLMOTS.MOTS(/2)
      SEGDES MLMOTS
      IF(NC .NE. (IDIM+2+NESP))THEN
         MOTERR(1:40) = 'LISTINCO = ???'
         WRITE(IOIMP,*) MOTERR
C
C******* Message d'erreur standard
C        21 2
C        Données incompatibles
C
         CALL ERREUR(21)
         GOTO 9999
      ENDIF
C
C**** La list des inconnues primales (variables primitives)
C
      TYPE='LISTMOTS'
      CALL LIROBJ(TYPE,ILIINP,1,IRET)
      IF(IERR .NE. 0) GOTO 9999
      MLMOTS = ILIINP
      SEGACT MLMOTS
      NC = MLMOTS.MOTS(/2)
      SEGDES MLMOTS
      IF(NC .NE. (IDIM+2+NESP))THEN
         MOTERR(1:40) = 'LISTINCO = ???'
         WRITE(IOIMP,*) MOTERR
C
C******* Message d'erreur standard
C        21 2
C        Données incompatibles
C
         CALL ERREUR(21)
         GOTO 9999
      ENDIF
C
C******* La densité au centre
C
      TYPE = 'CHPOINT '
      CALL LIROBJ(TYPE,IRN,1,IRET)
      IF(IERR .NE. 0) GOTO 9999
C
C**** Control du CHPOINT: QUEPOI
C
C     INDIC = 1   -> on impose le pointeur du support geometrique (ICEN)
C                   N.B. Le CHPOINT peut changer de structure pour
C                        avoir SPG = ICEN!!!!
C     INDIC = 0   -> on ne fait que verifier le support geometrique
C                   (ICEN). Si le SPG sont differents INDIC = -4 en sortie
C
C     NBCOMP > 0 -> numero des composantes
C
C     MOT  = ' ' obligatoire s'on connais pas les noms des composantes
C
      INDIC = 1
      NBCOMP = 1
      MOT = 'SCAL'
      CALL QUEPOI(IRN, MELEMC, INDIC, NBCOMP, MOT)
      IF(IERR .NE. 0) GOTO 9999
C
C******* La vitesse au centre
C
      TYPE = 'CHPOINT '
      CALL LIROBJ(TYPE,IVN,1,IRET)
      IF(IERR .NE. 0) GOTO 9999
      JGN = 4
      JGM = IDIM
      SEGINI MLMVIT
      MLMVIT.MOTS(1) = 'UX  '
      MLMVIT.MOTS(2) = 'UY  '
      IF(IDIM .EQ. 3) MLMVIT.MOTS(3) = 'UZ  '
      CALL QUEPO1(IVN, MELEMC, MLMVIT)
      SEGSUP MLMVIT
      IF(IERR .NE. 0) GOTO 9999
C
C******* La pression au centre
C
      TYPE = 'CHPOINT '
      CALL LIROBJ(TYPE,IPN,1,IRET)
      IF(IERR .NE. 0) GOTO 9999
      INDIC = 1
      NBCOMP = 1
      MOT = 'SCAL'
      CALL QUEPOI(IPN, MELEMC, INDIC, NBCOMP, MOT)
      IF(IERR .NE. 0) GOTO 9999
C
C******* Gamma au centre
C
      TYPE = 'CHPOINT '
      CALL LIROBJ(TYPE,IGAMN,1,IRET)
      IF(IERR .NE. 0) GOTO 9999
      INDIC = 1
      NBCOMP = 1
      MOT = 'SCAL'
      CALL QUEPOI(IGAMN, MELEMC, INDIC, NBCOMP, MOT)
      IF(IERR .NE. 0) GOTO 9999
C
C******* Calcul du jacobien
C
      IF(IDIM .EQ. 2)THEN
         CALL PRIJA1(MELEMC,ILIINC,ILIINP,IRN,IVN,IPN,IGAMN,IJACO)
         IF(IERR .NE. 0) GOTO 9999
      ELSE
         CALL PRIJA2(MELEMC,ILIINC,ILIINP,IRN,IVN,IPN,IGAMN,IJACO)
         IF(IERR .NE. 0) GOTO 9999
      ENDIF
C
C**** Ecriture des resultats
C
      TYPE='MATRIK '
      CALL ECROBJ(TYPE,IJACO)
 9999 CONTINUE
      RETURN
      END