Sources Esope | Cast3M

pendia
C PENDIA    SOURCE    OF166741  24/12/13    21:16:53     12097          
      SUBROUTINE PENDIA(IDOMA)
C************************************************************************
C
C PROJET            :  CASTEM 2000
C
C NOM               :  PENDIA
C
C DESCRIPTION       :  Appelle par PENT
C
C LANGAGE           :  FORTRAN 77 + ESOPE 2000 (avec extensions CISI)
C
C AUTEUR            :  A. BECCANTINI
C
C************************************************************************
C
C
C************************************************************************
C
C PHRASE D'APPEL (GIBIANE) :
C
C
C RCHPO1  RCHELEM1 = 'PENT'
C         MCLE1 MCLE2 MCLE3 TABDO CHPO1 (MCLE4 CHPO2) ;
C
C ou
C
C RCHPO1  = 'PENT'
C        MCLE1 MCLE2 MCLE3 TABDO CHPO1 (MCL4 CHPO2) MCLE5 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             'FACE' est autorisé;
C
C  MCLE2   :  Traitement des éléments de bord et ordre de précision du
C             calcul de gradient . Options sont possibles : 'DIAMANT'
C
C  MCLE3   :  Calcul ou non du limiteur : 'LIMITEUR' ou 'NOLIMITE';
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  MCLE4   :  Donnée ou non du RCHELEM1:
C             'GRADGEO' si donnée, vide sinon.
C
C
C E/S    :
C
C RCHELEM1: Champ par élément des coefficients géométriques pour le
C           calcul du gradient (et du hessien)
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************************************************************************
C
C HISTORIQUE (Anomalies et modifications éventuelles)
C
C HISTORIQUE : Creé le 2/3/2001
C
C************************************************************************
C
      IMPLICIT INTEGER(I-N)
 
-INC PPARAM
-INC CCOPTIO
-INC SMCHPOI
-INC SMLMOTS
C
      INTEGER IDOMA, IRET1, ICEN, IFACEL, IFACEP, ICELL, ISOMM
     &     ,ICHPO, ICHGRA,  ICOEFF
     &     ,NBCOMP
     &     ,ICHCL, ISGLIM, NSOUPO, IMAIL, IMOT
 
C
      CHARACTER*(8)  MOT,MTYPR
      LOGICAL LOGCOE
C+PPb On initialise parceque c'est utile...
      MOT=' '
C+PPb
C
C**** Lecture du MELEME SPG des points CENTRE.
C
      CALL LEKTAB(IDOMA,'CENTRE',ICEN)
      IF(IERR .NE. 0) GOTO 9999
C
C**** Lecture du MELEME SPG des points FACE.
C
      CALL LEKTAB(IDOMA,'FACE',IFAC)
      IF(IERR .NE. 0) GOTO 9999
C
C**** Lecture du MELEME SPG des points SOMMET
C
      CALL LEKTAB(IDOMA,'SOMMET',ISOMM)
      IF(IERR .NE. 0) GOTO 9999
C
C**** Lecture du MELEME de connect. FACEL
C
      CALL LEKTAB(IDOMA,'FACEL',IFACEL)
      IF(IERR .NE. 0) GOTO 9999
C
C**** Lecture du MELEME de connect. FACEP
C
      CALL LEKTAB(IDOMA,'FACEP',IFACEP)
      IF(IERR .NE. 0) GOTO 9999
C
C**** Lecture du MELEME MAILLAGE
C
      CALL LEKTAB(IDOMA,'MAILLAGE',IMAIL)
      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 CHPOIT
C
      MLMOTS=0
      CALL QUEPO1(ICHPO, ICEN, MLMOTS)
      IMOT=MLMOTS
      IF (IERR .NE. 0) GOTO 9999
C     En sortie, MLMOTS contient le nom de composantes de ICHPO
      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) THEN
               ICHCL=0
               ISGLIM=0
            ELSE
               MSOUPO=MCHPOI.IPCHP(1)
               SEGACT MSOUPO
               ISGLIM=MSOUPO.IGEOC
               SEGDES MSOUPO
            ENDIF
            SEGDES MCHPOI
         ELSE
C
C******* Je la remets dans la pile
C
            CALL ECRCHA(MOT)
            IF(IERR .NE. 0) GOTO 9999
            ICHCL=0
            ISGLIM=0
         ENDIF
      ELSE
         ISGLIM=0
         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 et (eventuelment) de l'hessian
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
      IF(IRET1 .EQ. 0)THEN
         LOGCOE = .TRUE.
      ELSEIF(MOT .NE. 'GRADGEO')THEN
         CALL ECRCHA(MOT)
         IF(IERR .NE. 0) GOTO 9999
         LOGCOE=.TRUE.
      ELSE
         LOGCOE=.FALSE.
         CALL LIROBJ('MCHAML  ',ICOEFF,1,IRET1)
         CALL ACTOBJ('MCHAML  ',ICOEFF,1)
         IF(IERR .NE. 0) GOTO 9999
      ENDIF
      IF(LOGCOE)THEN
         CALL GRADIA(ICEN,ISOMM,IFACEL,IFACEP,IMAIL,ISGLIM,
     &        ICOEFF)
         IF (IERR .NE. 0) GOTO 9999
      ENDIF
C
C**** Calcul de gradient
C
      CALL PENDI1(IMOT,IFAC,ICHPO,ICHCL,ICOEFF,ICHGRA)
      IF(IERR .NE. 0) GOTO 9999
C
C**** Ecriture de gradient, (hessian), (limiteur),
C     (MCHAMLs pour le calcul de gradient et/ou du hessian)
C
      IF(MOT .NE. 'GRADGEO') THEN
         CALL ACTOBJ('MCHAML  ',ICOEFF,1)
         CALL ECROBJ('MCHAML  ',ICOEFF)
         IF(IERR .NE. 0) GOTO 9999
      ENDIF
      CALL ACTOBJ('CHPOINT ',ICHGRA,1)
      CALL ECROBJ('CHPOINT ',ICHGRA)
      IF(IERR .NE. 0) GOTO 9999
C
      SEGSUP MLMOTS
C
C**** Sortie du programme
C
 9999 CONTINUE
      END