Télécharger vfsym.eso

Retour à la liste

vfsym
C VFSYM     SOURCE    CB215821  20/11/25    13:42:24     10792          
C NORV      SOURCE    PV        07/11/23    21:18:24     5978
      SUBROUTINE VFSYM(IDOMA)
C************************************************************************
C
C PROJET            :  CASTEM 2000
C
C NOM               :  NORV (OPERATEUR GIBIANE)
C
C DESCANDRIPTION       :  Calcul du gradient d'un CHPOINT 2D de type CENTRE
C                      Avec tenseur dispersif hétérogène
C                      Référence : Discretization on unstructured grids for
C                      inhomogenous, anisotropic media. Part 1:derivation of the
C                      methods,
C                      I AAVATSMARK, T. BARKVE, O BOE, AND T. MANNSETH
C                      SIAM JCP, VOL 19, n0 5, pp 1700-1716, Septembre 1998
C
C LANGAGE           :  FORTRAN 77 + ESOPE 2000 (avec extensions CISI)
C
C AUTEUR            :  C. LE POTIER, DM2S/SFME/MTMS
C
C************************************************************************
C
C
C************************************************************************
C
C PHRASE D'APPEL (GIBIANE) :
C
C
C RCHPO1  RCHELEM1 = 'PENT'
C         MCLE1 MCLE2 TABDO CHPO1  (MCLE6 CHPO3) (MCLE4 CHPO2)  ;
C
C ou
C
C RCHPO1  = 'PENT'
C        MCLE1 MCLE2  TABDO CHPO1 (MCLE6 CHPO3) (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 : 'NORVEGE'
C
C
C  CHPO1   :  Donnée du Champ par point de type MCLE1;
C
C  MCLE6   :  Donnée ou non de CHPO3
C             'DISPDIF'  si donnée, vide sinon
C
C  CHPO3   :  Donnée du Champ par point du tenseur de diffusion dispersion
C
C  MCLE4   :  Donnée ou non du CHPO2
C             'TIMP' si donnée, vide sinon.
C
C  CHPO2   :  Donnée du Champ par point des conditions aux limites
C
C  MCLE5   :  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 HISTORIQUE : 11/02/2003 Ajout d'une option Neuman et d'une option MIXTE
C            : Prise en compte de plusieurs sous domaines, Optimisation
C            : des paramètres NBMAX,NBNN de manière à optimiser la place
C            : mémoire et le temps calcul
C
C************************************************************************
C
C
 
C
C
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (a-h,o-z)
 
-INC PPARAM
-INC CCOPTIO
-INC SMCHPOI
-INC SMLMOTS
C
C**** Variables de COOPTIO
C
      INTEGER ICOND, IDOMA,  IRET1,  ICEN, IFACEL, IFACEP, ICELL, ISOMM
     &     ,NBOPT, IOPPOS, IOPMET, IOPLIM
     &     ,ICHPO, ICHGRA, IMCALP, ICOEFF
     &     ,NBCOMP
     &     ,ICHCL, ICHCLG, ICHHES, IFAC, INORM, IVOLUM, ISURF
     &     ,NSOUPO, IMAIL, ISGLIM,IELTFA,ICHTE
 
C
      CHARACTER*(8)  MOT,MTYPR
      CHARACTER*(7) GRAD(2)
      REAL*8 XKT
      INTEGER LOGBOR,LOGCOE,LOGCCL
      DATA GRAD/'GRADGEO','GRADGCL'/
C
C
C**** Lecture du MELEME SPG des points CENTRE.
C
c      CALL GIBTEM(XKT)
c      WRITE(6,*) 'PENT XKT=',XKT
      CALL LEKTAB(IDOMA,'CENTRE',ICEN)
      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 des points FACE
C
      CALL LEKTAB(IDOMA,'FACE',IFAC)
      IF (IERR .NE. 0) GOTO 9999
 
C
C**** Lecture du MELEME de connect. IELTFA
C
      CALL LEKTAB(IDOMA,'ELTFA',IELTFA)
      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 contenant les normales aux faces
C
      CALL LEKTAB(IDOMA,'XXNORMAF',INORM)
      IF (IERR .NE. 0) GOTO 9999
C
C
C**** Lecture du CHPOINT contenant les surfaces
C
      CALL LEKTAB(IDOMA,'XXSURFAC',ISURF)
      IF (IERR .NE. 0) GOTO 9999
 
 
C
C**** Lecture du CHPOINT dont on veut calculer le gradient!
C
      CALL LIROBJ('CHPOINT ',ICHPO,1,IRET1)
      IF(IERR .NE. 0) GOTO 9999
 
C**** Control du CHPOINT
C
      MLMOTS=0
      CALL QUEPO1(ICHPO, ICEN, 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 LECTURE DES TENSEURS DE DIFFUSIONS
      IRET1=0
      CALL LIRCHA(MOT,0,IRET1)
      IF(IERR .NE. 0) GOTO 9999
      IF(IRET1.NE.0)THEN
         IF(MOT .EQ. 'DISPDIF') THEN
            CALL LIROBJ('CHPOINT ',ICHTE,1,ICELL)
            MCHPOI = ICHTE
            SEGACT MCHPOI
            NSOUPO = MCHPOI.IPCHP(/1)
            IF(NSOUPO .EQ. 0) ICHTE=0
            SEGDES MCHPOI
         ELSE
C
C******* Je la remets dans la pile
C
            CALL ECRCHA(MOT)
            ICHTE=0
         ENDIF
      ELSE
         ICHTE=0
      ENDIF
C
C**** Lecture du CHPOINT du conditions aux limites dirichlet(optionel)
C
      IRET1=0
      CALL LIRCHA(MOT,0,IRET1)
      IF(IERR .NE. 0) GOTO 9999
      IF(IRET1.NE.0)THEN
         IF(MOT .EQ. 'TIMP') THEN
            CALL LIROBJ('CHPOINT ',ICHCL,1,ICELL)
            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)
            ICHCL=0
         ENDIF
      ELSE
         ICHCL=0
      ENDIF
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
C**** Lecture du CHPOINT du conditions aux limites Neuman (optionel)
C
      IRET1=0
      CALL LIRCHA(MOT,0,IRET1)
      IF(IERR .NE. 0) GOTO 9999
      IF(IRET1.NE.0)THEN
         IF(MOT .EQ. 'QIMP') THEN
            CALL LIROBJ('CHPOINT ',ICHNE,1,ICELL)
            MCHPOI = ICHNE
            SEGACT MCHPOI
            NSOUPO = MCHPOI.IPCHP(/1)
            IF(NSOUPO .EQ. 0) ICHNE=0
            SEGDES MCHPOI
         ELSE
C
C******* Je la remets dans la pile
C
            CALL ECRCHA(MOT)
            ICHNE=0
         ENDIF
      ELSE
         ICHNE=0
      ENDIF
 
C
C**** Lecture du CHPOINT du conditions aux limites mixtes (optionel)
C
      IRET1=0
      CALL LIRCHA(MOT,0,IRET1)
      IF(IERR .NE. 0) GOTO 9999
      IF(IRET1.NE.0)THEN
         IF(MOT .EQ. 'MIXT') THEN
            CALL LIROBJ('CHPOINT ',ICHMI,1,ICELL)
            MCHPOI = ICHMI
            SEGACT MCHPOI
            NSOUPO = MCHPOI.IPCHP(/1)
            IF(NSOUPO .EQ. 0) ICHMI=0
            SEGDES MCHPOI
         ELSE
C
C******* Je la remets dans la pile
C
            CALL ECRCHA(MOT)
            ICHMI=0
         ENDIF
      ELSE
         ICHMI=0
      ENDIF
 
      IRET1=0
      IOP = 0
      CALL LIRCHA(MOT,0,IRET1)
      IF(IERR .NE. 0) GOTO 9999
      IF(IRET1.NE.0)THEN
         IF ((MOT .EQ. 'UPWIND')
     &      .OR.(MOT .EQ. 'CENTERED')
     &      .OR.(MOT .EQ. 'UPWICENT'))  THEN
            IF (MOT .EQ. 'UPWIND') THEN
            IOP = 1
            ELSEIF (MOT .EQ. 'CENTERED') THEN
            IOP = 2
            ELSEIF (MOT .EQ. 'UPWICENT') THEN
            IOP = 3
            ENDIF
            CALL LIROBJ('CHPOINT ',ICHCO,1,ICELL)
            MCHPOI = ICHCO
            SEGACT MCHPOI
            NSOUPO = MCHPOI.IPCHP(/1)
            IF(NSOUPO .EQ. 0) ICHCO=0
            SEGDES MCHPOI
         ELSE
C
C******* Je la remets dans la pile
C
            CALL ECRCHA(MOT)
            ICHCO=0
         ENDIF
      ELSE
         ICHCO=0
      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
      LOGCOE = 1
      LOGCCL = 1
      LOGBOR = 1
      CALL LIRCHA(MOT,0,IRET1)
c      CALL LIRMOT(GRAD,2,ICELL,1)
      IF(IERR .NE. 0) GOTO 9999
      IF(IRET1 .EQ. 0)THEN
         LOGCOE = 1
         LOGCCL = 1
         LOGBOR = 1
      ELSEIF( (MOT .NE. 'GRADGEO') .AND.
     &        (MOT .NE. 'GRADGCL') .AND.
     &        (MOT .NE. 'GRADBOR'))  THEN
         CALL ECRCHA(MOT)
c         IF(IERR .NE. 0) GOTO 9999
         LOGCOE = 1
         LOGCCL = 1
         LOGBOR = 1
      ELSEIF (MOT .EQ. 'GRADGEO') THEN
         LOGCOE = 0
         CALL LIROBJ('MCHAML  ',ICOEFF,1,IRET1)
c         IF(IERR .NE. 0) GOTO 9999
         ELSEIF (MOT .EQ. 'GRADGCL') THEN
         LOGCCL = 0
         CALL LIROBJ('MCHAML  ',ICOEFF,1,IRET1)
c         IF(IERR .NE. 0) GOTO 9999
         ELSEIF (MOT .EQ. 'GRADBOR') THEN
         LOGBOR = 0
         CALL LIROBJ('MCHAML  ',ICOEFF,1,IRET1)
       ENDIF
 
c      IF(IERR .NE. 0)GOTO 9999
c      IF(ICELL .EQ. 1)THEN
c         LOGCOE = 0
c         CALL LIROBJ('MCHAML  ',ICOEFF,1,IRET1)
c         IF(IERR .NE. 0) GOTO 9999
c      ELSEIF(ICELL .EQ. 2)THEN
c         LOGCL = 0
c         CALL LIROBJ('MCHAML  ',ICOEFF,1,IRET1)
c         IF(IERR .NE. 0) GOTO 9999
c      ENDIF
 
 
 
 
 
         CALL VFSYM1(IOPPOS,ICEN,ISOMM,IFAC,IFACEL,IFACEP,IELTFA,IMAIL,
     &               INORM,ISURF,ICHPO,ICHTE,ICHCL,ICHNE,ICHMI,ICHCO,
     &               IOP,ICHGRA,MPOGRA,ICOEFF,LOGBOR,LOGCOE,LOGCCL)
 
 
      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') .AND. (MOT .NE.'GRADGCL')
     &                        .AND. (MOT .NE.'GRADBOR') ) THEN
         CALL ECROBJ('MCHAML',ICOEFF)
         IF(IERR .NE. 0) GOTO 9999
      ENDIF
      CALL ECROBJ('CHPOINT',ICHGRA)
      IF(IERR .NE. 0) GOTO 9999
C
      SEGSUP MLMOTS
C
C**** Sortie du programme
C
 9999 CONTINUE
C
      RETURN
      END
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 

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