Sources Esope | Cast3M

zzoimp
C ZZOIMP    SOURCE    FANDEUR   22/01/03    21:16:05     11136          
      SUBROUTINE ZZOIMP(MTABX,MTAB1)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C***********************************************************************
C     -----------------------------------------------------------
C     ---------  TOIMP   ----------------------------------------
C     -----------------------------------------------------------
C     ---------  PARAMETRI DELLO OPERATORE (NELLO ORDINE) : -----
C     -----------------------------------------------------------
C     ---------  TENSION ( tau et pression )            ---------
C     -----------------------------------------------------------
C
C     SYNTAXE :
C
C       TOIMP  (tau pression)
C
C       1------2
C       (R1,AL1)  LEF   FLUIDE  NOEUDS 1 2
C
C
C
C   CAS TRIDIMENSIONNEL
C                       4 ________ 3
C                       / FLUIDE /
C                    1 /________/2
C
C
C***********************************************************************
 
 
-INC PPARAM
-INC CCOPTIO
-INC SMCHAML
-INC SMCOORD
-INC SMLENTI
      POINTEUR IZIPAD.MLENTI
-INC SMELEME
      POINTEUR MELEM1.MELEME
-INC SMCHPOI
      POINTEUR IZG1.MCHPOI, IZGG1.MPOVAL
      POINTEUR IZTU1.MPOVAL
      POINTEUR MZTO.MPOVAL
      POINTEUR IZVOL.MPOVAL, IZTCO.MPOVAL
 
-INC SMLMOTS
      POINTEUR LINCO.MLMOTS
      CHARACTER*8 NOMZ,NOMA,TYPE,CHAI,TYPC
      CHARACTER*(LOCOMP) NOM,NOMI
      LOGICAL LOGI
      PARAMETER (NTB=1)
      CHARACTER*8 LTAB(NTB)
      DIMENSION KTAB(NTB),IXV(3)
      SAVE IPAS
      DATA LTAB/'KIZX    '/,IPAS/0/
C*****************************************************************************
CTOIMP
C     write(6,*)' Debut TOIMP '
C
C- Récupération de la table INCO (pointeur KINC)
C
      CALL LEKTAB(MTAB1,'INCO',KINC)
      IF(KINC.EQ.0)THEN
C Indice %m1:8 : Indice %m9:16 non trouvé dans la table %m17:24
         MOTERR( 1: 8) = '  INCO  '
         MOTERR( 9:16) = '  INCO  '
         MOTERR(17:24) = '  EQEX  '
         CALL ERREUR(786)
      RETURN
      ENDIF
 
C*****************************************************************************
C OPTIONS
C KIMPL = 0 -> EXPL     1 -> IMPL     2 -> SEMI
C KFORM = 0 -> SI       1 -> EF       2 -> VF    3 -> EFMC
C IDCEN = 0-> rien  1-> CENTREE  2-> SUPGDC  3-> SUPG  4-> TVISQUEU  5-> CNG
 
      IAXI=0
      IF(IFOMOD.EQ.0)IAXI=2
C
C- Récupération de la table des options KOPT (pointeur KOPTI)
C
      CALL LEKTAB(MTABX,'KOPT',KOPTI)
      IF (KOPTI.EQ.0) THEN
C Indice %m1:8 : Indice %m9:16 non trouvé dans la table %m17:24
         MOTERR( 1: 8) = '  KOPT  '
         MOTERR( 9:16) = '  KOPT  '
         MOTERR(17:24) = '  KIZX  '
         CALL ERREUR(786)
         RETURN
      ENDIF
 
C?    CALL ACME(KOPTI,'MTRMASS ',MMPG)
C?    IPG=0
C?    IF(MMPG.EQ.3)IPG=1
C?    CALL ACME(KOPTI,'IDCEN',IDCEN)
      CALL ACME(KOPTI,'KIMPL',KIMPL)
      CALL ACME(KOPTI,'KFORM',KFORM)
 
      IF(KFORM.NE.0.AND.KFORM.NE.1)THEN
C        Option %m1:8 incompatible avec les données
            MOTERR( 1: 8) = 'EF/EFM1 '
            CALL ERREUR(803)
            RETURN
        ENDIF
      IF (IERR.NE.0) RETURN
 
C     write(6,*)' Apres les options '
C*****************************************************************************
C
C- Récupération de la table DOMAINE associée au domaine local
C
      CALL ACMM(MTABX,'NOMZONE',NOMZ)
      CALL LEKTAB(MTABX,'DOMZ',MTABZ)
      IF(MTABZ.EQ.0)THEN
C Indice %m1:8 : Indice %m9:16 non trouvé dans la table %m17:24
         MOTERR( 1: 8) = '  DOMZ  '
         MOTERR( 9:16) = '  DOMZ  '
         MOTERR(17:24) = '  KIZX  '
         CALL ERREUR(786)
         RETURN
      ENDIF
 
      CALL LEKTAB(MTABZ,'MAILLAGE',MELEME)
      CALL LEKTAB(MTABZ,'CENTRE',MELEMC)
      CALL LEKTAB(MTABZ,'XXPSOML',MCHELM)
      CALL LEKTAB(MTABZ,'XXCOTE',MCHPCO)
      IF (IERR.NE.0) RETURN
 
      SEGACT MELEME
      SEGACT MCHELM
      CALL LICHT(MCHPCO,IZTCO,TYPC,IGEOM)
      NCOT=IZTCO.VPOCHA(/2)
 
C*************************************************************************
C VERIFICATIONS SUR LES INCONNUES
C
C- Récupération du nombre d'inconnues et du nom de l'inconnue NOMI
C
      TYPE='LISTMOTS'
      CALL ACMO(MTABX,'LISTINCO',TYPE,LINCO)
      IF (IERR.NE.0) RETURN
      SEGACT LINCO
      NBINC=LINCO.MOTS(/2)
      IF(NBINC.NE.1)THEN
C        Indice %m1:8 : contient plus de %i1 %m9:16
         MOTERR( 1:8) = 'LISTINCO'
         INTERR(1) = 1
         MOTERR(9:16) = ' MOTS   '
         CALL ERREUR(799)
      RETURN
      ENDIF
 
C --> 1 ere Inconnue
 
      NOMI=LINCO.MOTS(1)
 
      TYPE=' '
      CALL ACMO(KINC,NOMI,TYPE,MCHPOI)
      IF(TYPE.NE.'CHPOINT ')THEN
C        Indice %m1:8 : ne contient pas un objet de type %m9:16
         MOTERR( 1: 8) = 'INC '//NOMI
         MOTERR( 9:16) = 'CHPOINT '
         CALL ERREUR(800)
      RETURN
      ELSE
      CALL LICHT(MCHPOI,IZTU1,TYPC,MELEM1)
      ENDIF
 
C*************************************************************************
C Le domaine de definition est donne par le SPG  de la premiere inconnue
C Les inconnues suivantes devront posseder ce meme pointeur
C On verifie que les points de la zone sont tous inclus dans ce SPG
 
      CALL KRIPAD(MELEM1,IZIPAD)
 
      IF(IPAS.EQ.0)THEN
      CALL VERPAD(IZIPAD,MELEME,IRET)
      IF(IRET.NE.0)THEN
C     Indice %m1:8 : L'objet %m9:16 n'a pas le bon support géométrique
         MOTERR(1: 8) = 'INC '//NOMI
         MOTERR(9:16) = 'CHPOINT '
         CALL ERREUR(788)
      IPAS=0
      RETURN
      ENDIF
      ENDIF
 
C*************************************************************************
C Lecture du coefficient
C Type du coefficient :
C IK1=0 CHPOINT IK1=1 scalaire  IK1=2 vecteur
 
      CALL ACME(MTABX,'IARG',IARG)
      IF(IARG.NE.1)THEN
      WRITE(6,*)'Opérateur TOIMP : nombre d''arguments incorrect'
C           Indice %m1:8 : nombre d'arguments incorrect
            MOTERR(1:8) = 'IARG    '
            CALL ERREUR(804)
      RETURN
      ENDIF
 
      IXV(1)=-MELEMC
      IXV(2)=0
      IXV(3)=1
      CALL LEKCOF('Opérateur TOIMP :',
     & MTABX,KINC,1,IXV,MTO,MZTO,NTAU,NC1,IKS,IRET)
      IF(IRET.EQ.0)RETURN
 
      IF(IKS.EQ.2)IKS=1
 
C     write(6,*)' Fin lecture Arguments '
C Fin lecture Arguments ************************************************
 
 
C     write(6,*)' Kform=',kform,' KIMPL=',kimpl
      IF(KIMPL.EQ.0)THEN
      IKIMPL=1
      CALL LEKTAB(MTAB1,'KIZG',KIZG)
      IF(KIZG.EQ.0)THEN
      CALL CRTABL(KIZG)
      CALL ECMM(KIZG,'SOUSTYPE','KIZG')
      CALL ECMO(MTAB1,'KIZG','TABLE   ',KIZG)
      ENDIF
 
      TYPE=' '
      CALL ACMO(KIZG,NOMI,TYPE,IZG1)
      IF(TYPE.NE.'CHPOINT ')THEN
      NC=IZTU1.VPOCHA(/2)
      TYPE='SOMMET'
      CALL CRCHPT(TYPE,MELEM1,NC,IZG1)
      CALL ECMO(KIZG,NOMI,'CHPOINT ',IZG1)
      ENDIF
 
      ELSE
 
      IKIMPL=-1
 
      NAT=2
      NSOUPO=1
      SEGACT MELEM1
      N=MELEM1.NUM(/2)
      NC=IZTU1.VPOCHA(/2)
      NINKO=NC
      SEGINI MCHPO1,MSOUP1,MPOVA1
      MCHPO1.IFOPOI=IFOUR
      MCHPO1.MOCHDE=TITREE
      MCHPO1.MTYPOI='SMBR'
      MCHPO1.JATTRI(1)=2
      MCHPO1.IPCHP(1)=MSOUP1
      DO 177 N=1,NINKO
        WRITE(NOM,FMT='(I1)')N
        NOM=NOM(1:1)//NOMI(1:LOCOMP-1)
        MSOUP1.NOCOMP(N)=NOM
 177  CONTINUE
      MSOUP1.IGEOC=MELEM1
      MSOUP1.IPOVAL=MPOVA1
      IZG1=MCHPO1
 
      ENDIF
 
      CALL LICHT(IZG1,IZGG1,TYPC,IGEOM)
 
      IF(IGEOM.NE.MELEM1)THEN
      WRITE(6,*)' Opérateur TOIM'
      WRITE(6,*)' Incompatibilité de SPG entre 1ères inconnues'
      RETURN
      ENDIF
 
      SEGACT MELEME
      NBSOUS=LISOUS(/1)
      IF(NBSOUS.EQ.0)NBSOUS=1
      NUTOEL=0
 
      NPTD=IZGG1.VPOCHA(/1)
 
      DO 1 L=1,NBSOUS
      IPT1=MELEME
      IF(NBSOUS.NE.1)IPT1=LISOUS(L)
      SEGACT IPT1
 
      MCHAML=ICHAML(L)
      SEGACT MCHAML
      MELVAL=IELVAL(1)
      SEGACT MELVAL
 
      NP  =IPT1.NUM(/1)
      NBEL=IPT1.NUM(/2)
 
      CALL ZTOIMP(NBEL,NUTOEL,NP,IZIPAD.LECT,IPT1.NUM,
     & VELCHE,IZTCO.VPOCHA,NCOT,IKIMPL,
     & IZTU1.VPOCHA,IZGG1.VPOCHA,NPTD,MZTO.VPOCHA,NTAU,IKS)
 
C     write(6,*)' TO '
C     write(6,1002)(IZGG1.VPOCHA(ii,1),ii=1,nptd)
C     write(6,*)' TO 2'
C     write(6,1002)(IZGG1.VPOCHA(ii,2),ii=1,nptd)
 
 
 
      SEGDES MZTO
      SEGDES IPT1,MCHAML,MELVAL
      NUTOEL=NUTOEL+NBEL
 
 1    CONTINUE
 
      IF(KIMPL.NE.0)THEN
      TYPE=' '
      CALL ACMO(MTAB1,'SMBR',TYPE,MCHPO2)
 
      IF(TYPE.NE.'CHPOINT')THEN
C     write(6,*)' IZG1=',izg1
      CALL ECMO(MTAB1,'SMBR','CHPOINT',IZG1)
      ELSE
      CALL ECROBJ('CHPOINT',MCHPO2)
      CALL ECROBJ('CHPOINT',IZG1)
      CALL PRFUSE
      CALL LIROBJ('CHPOINT',MCHPOI,1,IRET)
      CALL ECMO(MTAB1,'SMBR','CHPOINT',MCHPOI)
      ENDIF
 
      ENDIF
 
      SEGDES MELEME
 
      SEGDES IZTU1
      SEGDES IZG1,IZGG1
      SEGDES LINCO
      SEGSUP IZIPAD
      IPAS=1
C     write(6,*)' FIN TOIMP '
      RETURN
 90   CONTINUE
      WRITE(6,*)' Interuption anormale de TOIMP '
C        Option %m1:8 incompatible avec les données
            MOTERR( 1: 8) = '  EF    '
      CALL ERREUR(803)
      RETURN
 1002 FORMAT(10(1X,1PE11.4))
      END