Sources Esope | Cast3M

pent15
C PENT15    SOURCE    CB215821  20/11/25    13:35:35     10792          
      SUBROUTINE PENT15(IDOMA,IOP2,IOP3)
C************************************************************************
C
C PROJET            :  CASTEM 2000
C
C NOM               :  PENT15
C
C DESCRIPTION       :  Appellé par PENT
C
C LANGAGE           :  FORTRAN 77 + ESOPE 2000 (avec extensions CISI)
C
C AUTEUR            :  A. BECCANTINI,  R. MOREL, DRN/DMT/SEMT/LTMF
C
C************************************************************************
C
C
C PHRASE D'APPEL (GIBIANE) :
C
C
C RCHPO1 RCHPO2 RCHELEM1 = 'PENT'
C         MCLE1 MCLE2 MCLE3 TABDO LMOT CHPO1 (MCLE4 CHPO2) ;
C
C ou
C
C RCHPO1 RCHPO2  = 'PENT'
C        MCLE1 MCLE2 MCLE3 TABDO LMOT CHPO1 (MCL4 CHPO2) 'GRADGEO' RCHELEM1 ;
C
C
C Entrées:
C
C  TABDO   :  Donnée de la table domaine;
C
C  MCLE1   :  type du champ par point CHPO1. Pour le moment, seul le type
C             'CENTRE' est autorisé;
C
C  MCLE2   :  Traitement des éléments de bord et ordre de précision du
C             calcul de gradient . Options sont possibles : 'BORDNULL',
C             'EULESCAL', 'EULEVECT', 'LINEXACT', 'QUADRATI'
C
C  MCLE3   :  Calcul ou non du limiteur : 'LIMITEUR' ou 'NOLIMITE';
C
C  LMOT    :  noms de composantes du chpoint
C
C  CHPO1   :  Donnée du Champ par point de type MCLE1;
C
C  MCLE4   :  Donnée ou non du CHPO2
C             'CLIM' si donnée, vide sinon.
C
C  CHPO2   :  Donnée du Champ par point des conditions aux limites
C
C
C
C E/S    :
C
C RCHELEM1: Champ par élément des coefficients géométriques pour le
C           calcul du gradient
C           (entrée si MCLE4 = 'GRADGEO', sinon sortie).
C
C
C Sorties:
C
C RCHPO1 :  Champ par point contenant le gradient de CHPO1 (toujours
C           calculé) ;
C
C RCHPO2 :  Champ par point contenant le limiteur du gradient
C           (toujours calculé) ;
C
C
C************************************************************************
C
C HISTORIQUE (Anomalies et modifications éventuelles)
C
C HISTORIQUE : Recreé le 22/3/2000
C
C************************************************************************
C
C
      IMPLICIT INTEGER(I-N)
 
-INC PPARAM
-INC CCOPTIO
-INC SMCHPOI
-INC SMLMOTS
C
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
C     &     ,MCOORD
C     &     ,IFOMOD, NIFOUR, IFOUR, NSDPGE, IONIVE
C     &     ,NGMAXY, IZROSF, ISOTYP, IOSCR,LTEXLU
C     &     ,NORINC,NORVAL,NORIND,NORVAD
C     &     ,NUCROU, IPSAUV, IFICLE, IPREFI
C     &     ,IREFOR, ISAFOR
C
      INTEGER IDOMA,  IRET1,  ICEN, IFACEL, IELTFA
     &     ,IOP2, IOP3
     &     ,ICHPO, ICHGRA, IMCALP
     &     ,NBCOMP
     &     ,ICHCL,  IFAC, INORM
     &     ,NSOUPO, ICELL, LMOT, JGM, JGN, ICHAM
 
C
      CHARACTER*(8)  MOT
C
      MOT='        '
C
C*************************************************
C****  TABLE DOMAINE  ****************************
C*************************************************
C
C**** Lecture du MELEME SPG des points CENTRE.
C
      CALL LEKTAB(IDOMA,'CENTRE',ICEN)
      IF(IERR .NE. 0) GO TO 9999
C
C**** Lecture du MELEME de connect. FACEL
C
      CALL LEKTAB(IDOMA,'FACEL',IFACEL)
      IF(IERR .NE. 0) GO TO 9999
C
C**** Lecture du MELEME de connect. ELTFA
C
      CALL LEKTAB(IDOMA,'ELTFA',IELTFA)
      IF(IERR .NE. 0) GO TO 9999
C
C**** Lecture du MELEME de connect. FACEL
C
      CALL LEKTAB(IDOMA,'FACE',IFAC)
      IF(IERR .NE. 0) GO TO 9999
C
C**** Lecture du MELEME de connect. FACEL
C
      CALL LEKTAB(IDOMA,'XXNORMAF',INORM)
      IF(IERR .NE. 0) GO TO 9999
      JGN=4
      JGM=IDIM
      SEGINI MLMOT1
      MLMOT1.MOTS(1)='UX  '
      MLMOT1.MOTS(2)='UY  '
      IF(IDIM.EQ.3) MLMOT1.MOTS(3)='UZ  '
      CALL QUEPO1(INORM, IFAC, MLMOT1)
      IF (IERR .NE. 0) GOTO 9999
      SEGSUP MLMOT1
C
C****************************************************
C
C
C**** Lecture des noms des composantes du CHPOINT
C
      CALL LIROBJ('LISTMOTS',LMOT,1,IRET1)
      IF(IERR .NE. 0) GOTO 9999
C
C**** Lecture du CHPOINT dont on veut calculer le gradient!
C
      CALL LIROBJ('CHPOINT ',ICHPO,1,IRET1)
      CALL ACTOBJ('CHPOINT ',ICHPO,1)
      IF(IERR .NE. 0) GOTO 9999
C
C**** Control du CHPOINT
C
      CALL QUEPO1(ICHPO, ICEN, LMOT)
      IF (IERR .NE. 0) GOTO 9999
C
      MLMOTS=LMOT
      SEGACT MLMOTS
      NBCOMP = MLMOTS.MOTS(/2)
      SEGDES MLMOTS
      IF(NBCOMP .GT. 9)THEN
C
C******* Message d'erreur standard
C        -301 0 %m1:40
C
         MOTERR(1:40) = 'NBCOMP > 9                              '
         WRITE(IOIMP,*) MOTERR(1:40)
         CALL ERREUR(22)
         GOTO 9999
      ENDIF
C
C**** Lecture du CHPOINT du conditions aux limites (optionel)
C
      IRET1=0
      CALL LIRCHA(MOT,0,IRET1)
      IF(IERR .NE. 0) GOTO 9999
      IF(IRET1.NE.0)THEN
         IF(MOT .EQ. 'CLIM') THEN
            CALL LIROBJ('CHPOINT ',ICHCL,1,ICELL)
            CALL ACTOBJ('CHPOINT ',ICHCL,1)
            IF(IERR .NE. 0) GOTO 9999
            MCHPOI = ICHCL
            SEGACT MCHPOI
            NSOUPO = MCHPOI.IPCHP(/1)
            IF(NSOUPO .EQ. 0) ICHCL=0
            SEGDES MCHPOI
         ELSE
C
C******* Je la remets dans la pile
C
            CALL ECRCHA(MOT)
            IF(IERR .NE. 0) GOTO 9999
            ICHCL=0
         ENDIF
      ELSE
         ICHCL=0
      ENDIF
C
C**** Control du CHPOIT
C     N.B.: MLMOTS contient les composantes de ICHPO
C
      IF(ICHCL .GT. 0)THEN
         ICELL = 0
         CALL QUEPO1(ICHCL, ICELL, MLMOTS)
         IF (IERR .NE. 0) GOTO 9999
      ENDIF
C
C**** Lecture du MCHAMLs qui contiennent les elements de matrice
C     pour le calcul du gradient
C
C     Si MOT = 'GRADGEO', on a ces MCHAMLs; sinon il faut le calculer
C
      CALL LIRCHA(MOT,0,IRET1)
      IF(IERR .NE. 0) GOTO 9999
C
C******* IOP2      1         2
C             'EULESCAL','EULEVECT'
C
      IF(MOT .NE. 'GRADGEO') THEN
         IF (IOP2.LE.3) THEN
C            CALL GRADGE(IDOMA,IOP2,ICHCL,MCHEL7)
            CALL GRADGE(ICEN,IELTFA,IFAC,IFACEL,INORM,ICHCL,ICHAM)
            IF (IERR .NE. 0) GOTO 9999
         ELSE
            CALL ERREUR(5)
            GOTO 9999
         ENDIF
      ELSE
         CALL LIROBJ('MCHAML  ',ICHAM,1,IRET1)
         CALL ACTOBJ('MCHAML  ',ICHAM,1)
         IF (IERR .NE. 0) GOTO 9999
      ENDIF
C
C**** Calcul de gradient
C
      CALL PENTE1(ICEN,IFAC,IFACEL,INORM,IOP2,IOP3,ICHAM,ICHPO,
     &     ICHCL,ICHGRA,IMCALP)
C
C**** Anomalie in PENTE1
C
      IF(IERR .NE. 0) GOTO 9999
C
C**** Ecriture de gradient, limiteur,
C     (MCHAMLs pour le calcul de gradient)
C
      IF(MOT .NE. 'GRADGEO') THEN
         CALL ACTOBJ('MCHAML  ',ICHAM,1)
         CALL ECROBJ('MCHAML  ',ICHAM)
         IF(IERR .NE. 0) GOTO 9999
      ENDIF
      IF(IERR .NE. 0) GOTO 9999
      CALL ACTOBJ('CHPOINT ',IMCALP,1)
      CALL ECROBJ('CHPOINT ',IMCALP)
      IF(IERR .NE. 0) GOTO 9999
C
      CALL ACTOBJ('CHPOINT',ICHGRA,1)
      CALL ECROBJ('CHPOINT',ICHGRA)
      IF(IERR .NE. 0) GOTO 9999
C
C**** Sortie du programme
C
 9999 CONTINUE
      END