Télécharger trajec.eso

Retour à la liste

trajec
C TRAJEC    SOURCE    CB215821  24/04/12    21:17:21     11897          
      SUBROUTINE TRAJEC
C     CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C   CE SOUS PROGRAMME  GERE L'OPERATEUR TRAJ DE CALCUL DE TRAJECTOIRES
C                   ( cf Rapport DMT/94/707)
C
C         Appelé par PILOT
C         lit les données CHPOIN des vitesses ou des flux
C                             ou tables transitoires
C                          MODELE ou TABLE  domaine
C                          TABLE de lacher
C         appelle : TRJCN1 et TRJCN3  qui controlent les données
C                 : TRJFLU et TRJVIT qui preparent les données relatives
C                      au flux ou à la vitesse.
C                 : TRJPAR  qui décode la table de lacher et
C                    pilote le calcul
C
C       Auteur : F Auriol
C
C     CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
 
-INC SMTABLE
-INC SMELEME
-INC SMCHPOI
-INC SMLREEL
-INC PPARAM
-INC CCOPTIO
-INC SMCHAML
-INC SMMODEL
 
      CHARACTER*8 MTYPI,CHARI,MTYPR,CHARR
      POINTEUR IZLAC.MELEME,IELTFA.MELEME,IZCENT.MELEME,IFACEL.MELEME
      POINTEUR IZFACE.MELEME
      POINTEUR MTABTR.MTABLE
      CHARACTER*20 MOCAL(3)
      SEGMENT IZVIT
           REAL*8 TEMTRA(NVIPT)
           INTEGER IPUN(NBS),IDUN(NBS),IPVPT(NVIPT),IFORML
      ENDSEGMENT
C             IDUN(I) nombre d elements avant le sous maillage I
C             IPVPT  pointeurs de izvpt pour chaque pas de temps
      SEGMENT IZVPT
           INTEGER IPUN1(NBS),IPUMAX
      ENDSEGMENT
      SEGMENT IZUN
           REAL*8 UN(I1,I2,I3)
      ENDSEGMENT
      POINTEUR IZUN1.IZUN ,IZUN2.IZUN
      SEGMENT IZUMAX
           REAL*8 UMAX(NBREL)
      ENDSEGMENT
      DATA MOCAL/'CONVECTION_EXPLICITE','CONVECTION_ANALYTIQU',
     * 'CONVECTION_DIFFUSION'/
C
      IRETOU=0
 
C     LECTURE DU TYPE DE CALCUL
      IRAN=0
      CALL LIRMOT(MOCAL,3,IRAN,0)
      IICAL=IRAN
      IF(IRAN.EQ.0)IICAL=1
 
C     LA VITESSE
      CALL LIROBJ('CHPOINT',MCHPOI,0,IRETOU)
            IF(IRETOU.NE.0)THEN
            IPTVIT=MCHPOI
            ITR=1
            SEGACT MCHPOI
            NSOUPO=IPCHP(/1)
            IF(NSOUPO.NE.1)THEN
                  CALL ERREUR(21)
                  RETURN
            ENDIF
            MSOUPO=IPCHP(1)
            SEGACT MSOUPO
C           ON VA TESTER LE NOM DES COMPOSANTES POUR DETERMINER
C           LA FORMULATION : ELEM FINIS OU MIXTE HYBRIDES
            IF(IIMPI.GT.0) WRITE(IOIMP,*)NOCOMP(1)
            IF(NOCOMP(1).EQ.'FLUX')THEN
                 IFORMU=2
                 IF(IIMPI.GT.0)WRITE(IOIMP,*)' FORMULATION HYBRIDE '
            ELSEIF(NOCOMP(1).EQ.'VX  ' )THEN
                 IFORMU=1
                 IF(IIMPI.GT.0)
     *        WRITE(IOIMP,*)' FORMULATION ELEMENTS FINIS ',NOCOMP(2)
                 IF(NOCOMP(2).NE.'VY  ')THEN
                       MOTERR=NOCOMP(2)
                       CALL ERREUR(197)
                       RETURN
                 ENDIF
            ELSE
                 MOTERR=NOCOMP(1)
                 CALL ERREUR(197)
                 RETURN
            ENDIF
      ELSE
              CALL LIRTAB('DARCY_TRANSITOIRE',MTABTR,0,IRETOU)
              IF (IRETOU.NE.0)THEN
                  ITR=3
                  IFORMU=2
                  IPTVIT=MTABTR
              ELSE
                  CALL LIRTAB('TRANSITOIRE',MTABTR,1,IRETOU)
                  IF (IRETOU.EQ.0)RETURN
                  ITR=3
                  IFORMU=1
                  IPTVIT=MTABTR
              ENDIF
      ENDIF
 
C     MODELE OU TABLE DOMAINE
C     LE TYPE DU MODELE EST TESTE DANS LEKMOD
      IRETOU=0
      MTAB1=0
      MCHELM=0
      CALL LIROBJ('MMODEL',IPMODE,0,IRET)
      IF(IRET.NE.0)THEN
           CALL LEKMOD(IPMODE,MTAB1,INEFMD)
      ELSE
           CALL LIRTAB('DOMAINE',MTAB1,1,IRETOU)
           IF(IRETOU.EQ.0)THEN
           MOTERR(1:40)='                                        '
                 MOTERR(1:8)='MODELE  '
                 MOTERR(9:16) ='   TABLE'
                 MOTERR(17:24)='_DOMAINE'
                 CALL ERREUR(471)
                 RETURN
           ENDIF
      ENDIF
 
C     LECTURE DES MCHAML
      IZPOR=0
      IZDIFF=0
      IZDISP=0
   20 CONTINUE
      CALL LIRCHA(CHARI(1:4),0,IRET)
      IF(IRET.NE.0)THEN
         IF(CHARI(1:4).EQ.'PORO')THEN
            CALL LIROBJ('MCHAML  ',IRET1,1,IRET2)
            IF(IRET2.EQ.0)THEN
               MOTERR(1:8)='PORO    '
               MOTERR(9:16)='MCHAML  '
               CALL ERREUR(929)
               RETURN
            ENDIF
            IZPOR=IRET1
            GO TO 20
         ELSEIF(CHARI(1:4).EQ.'DISP')THEN
            CALL LIROBJ('MCHAML  ',IRET1,1,IRET2)
            IF(IRET2.EQ.0)THEN
               MOTERR(1:8)='DISP    '
               MOTERR(9:16)='MCHAML  '
               CALL ERREUR(929)
               RETURN
            ENDIF
            IZDISP=IRET1
            IICAL=3
            GO TO 20
         ELSEIF(CHARI(1:4).EQ.'DIFF')THEN
            CALL LIROBJ('MCHAML  ',IRET1,1,IRET2)
            IF(IRET2.EQ.0)THEN
               MOTERR(1:8)='DIFF    '
               MOTERR(9:16)='MCHAML  '
               CALL ERREUR(929)
               RETURN
            ENDIF
            IZDIFF=IRET1
            IICAL=3
            GO TO 20
         ENDIF
      ENDIF
 
C     LE MAILLAGE
      SEGACT MTAB1
      IRETR=0
      CHARI='MAILLAGE'
      CALL LEKTAB(MTAB1,CHARI,IRETR)
       MELEME=IRETR
 
      CALL TRJCN1(MELEME)
      IF(IERR.NE.0)RETURN
      SEGACT MELEME
C     ON RECUPERE LE MAILLAGE DES POINTS CENTRES
      IRETR=0
      CALL LEKTAB(MTAB1,'CENTRE',IRETR)
      IZCENT=IRETR
C     ON RECUPERE LE MAILLAGE DES FACES PAR ELEMENTS
      IRETR=0
      CALL LEKTAB(MTAB1,'ELTFA',IRETR)
      IELTFA=IRETR
C     ON RECUPERE LE LAISONS FACES CENTRES
      IRETR=0
      CALL LEKTAB(MTAB1,'FACEL',IRETR)
      IFACEL=IRETR
C     controle de la coherence vitesse maillage
      MCHPO1=MCHPOI
      IF(IFORMU.EQ.1)THEN
           NCC=IDIM
           IF(ITR.NE.3)THEN
           CALL TRJCN3(MCHPO1,MELEME,NCC)
           ELSE
           IVALI=1
           XVALI=0.D0
           IRETI=0
           IVALR=0
           XVALR=0.D0
           MTYPI='MOT'
           CHARR='        '
           MTYPR='TABLE'
           CALL ACCTAB(IPTVIT,MTYPI,IVALI,XVALI,'VITESSE',.TRUE.,
     *      IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR)
           MTABFT=IRETR
           CALL TRJCN6(MTABFT,MELEME,NCC)
           ENDIF
           IF(IERR.NE.0)RETURN
           CALL TRJVIT(IPTVIT,ITR,MELEME,IZVIT)
           IF(IERR.NE.0)RETURN
      ELSEIF(IFORMU.EQ.2)THEN
C          ON RECUPERE LE MAILLAGE FACES
           IVALI=0
           XVALI=0.D0
           IRETI=0
           IVALR=0
           XVALR=0.D0
           IRETR=0
           MTYPI='MOT     '
           MTYPR='MAILLAGE'
           CHARR='MAILLAGE'
           CALL LEKTAB(MTAB1,'FACE',IRETR)
           IZFACE=IRETR
           NCC=1
           SEGACT IZFACE
           IF(ITR.NE.3)THEN
           CALL TRJCN3(MCHPO1,IZFACE,NCC)
           ELSE
           IVALI=1
           XVALI=0.D0
           IRETI=0
           IVALR=0
           XVALR=0.D0
           MTYPI='MOT'
           CHARR='        '
           MTYPR='TABLE'
           CALL ACCTAB(IPTVIT,MTYPI,IVALI,XVALI,'FLUX',.TRUE.,
     *                 IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR)
           MTABFT=IRETR
           CALL TRJCN6(MTABFT,IZFACE,NCC)
           ENDIF
           SEGDES IZFACE
           IF(IERR.NE.0)RETURN
           CALL LEKTAB(MTAB1,'XXNORMAE',MCHELM)
           IF(IERR.NE.0)RETURN
           CALL TRJFLU(IPTVIT,ITR,MCHELM,IELTFA,MELEME,IZVIT)
           IF(IERR.NE.0)RETURN
      ENDIF
 
C     LA TABLE DE LACHER
      CALL LIROBJ('TABLE',MTAB2,1,IRETOU)
      IF(IRETOU.EQ.0)RETURN
 
C     ON CREE LA PILE RESULTAT
      CALL CRTABL(MTAB3)
C
      IERR=0
      CALL TRJPAR(MELEME,IZVIT,IZCENT,IELTFA,IFACEL,MTAB2,IICAL,IZPOR,
     *            IZDIFF,IZDISP,MCHEL1,MMODE1 )
      IF(IERR.NE.0)RETURN
 
      SEGDES IZCENT,IFACEL
      NBS=IELTFA.LISOUS(/1)
      IF(NBS.NE.0)THEN
           DO 81 I=1,NBS
           IPT1=IELTFA.LISOUS(I)
           SEGDES IPT1
   81      CONTINUE
      ENDIF
      SEGDES IELTFA
      NBS=LISOUS(/1)
      IF(NBS.NE.0)THEN
           DO 83 I=1,NBS
           IPT1=LISOUS(I)
           SEGDES IPT1
   83      CONTINUE
      ENDIF
      SEGDES MELEME
      SEGDES MTAB2
      SEGDES MTAB1
      IF(IERR.NE.0)RETURN
      SEGACT IZVIT
      NBS=IPUN(/1)
      DO 80 I=1,NBS
         IZUN=IPUN(I)
         SEGSUP IZUN
   80 CONTINUE
      NVIPT= IPVPT(/1)
      DO 85 J=1,NVIPT
         IZVPT=IPVPT(J)
         SEGACT IZVPT
         DO 82 I=1,NBS
         IZUN1=IPUN1(I)
         IF(IZUN1.NE.0)SEGSUP IZUN1
   82    CONTINUE
      IZUMAX=IPUMAX
      SEGSUP IZUMAX
      SEGSUP IZVPT
   85 CONTINUE
      SEGSUP IZVIT
 
C     ON SAUVEGARDE LES RESULTATS
      CALL ECROBJ('MCHAML  ',MCHEL1)
      CALL ECROBJ('MMODEL  ',MMODE1)
      SEGDES MCHEL1,MMODE1
 
      RETURN
      END
 
 
 
 
 
 
 
 

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