C TRJVIT    SOURCE    CB215821  20/11/25    13:41:40     10792          
      SUBROUTINE TRJVIT(IPTVIT,ITR,MELEME,IZVIT)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C           MET LES VITESSES SOUS UNE FORME AGREABLE POUR LE
C                 CALCUL DES TRAJECTOIRES
C      ENTREES
C          IPTVIT= MCHPOI1 POINTEUR DU CHAMPOIN DES VITESSES INITIALES
C                        (  EN PERMANENT)
C                = POINTEUR DE LA TABLE DES CHAMPOIN DES VITESSES
C                 INITIALES ( EN TRANSITOIRE)
C          ITR  = 3  TRANSITOIRE
C          MELEME POINTEUR DU MAILLAGE
C      SORTIE
C          IZVIT  POINTEUR DU SEGMENT CONTENANT LES POINTEURS
C                  DES IZUN
C
C  on suppose que NSOUPO=1 et qu en transitoire les vitesses sont
C       donnees aux memes noeuds ( controlé en amont)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-INC SMELEME
-INC SMCHPOI
-INC SMTABLE
      POINTEUR MTABTT.MTABLE,MTABFT.MTABLE
C
      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
C         UMAX vitesse max dans chaque element utilsee dans TRJCOU
      SEGMENT IZUMAX
           REAL*8 UMAX(NBREL)
      ENDSEGMENT
      SEGMENT IZBID
           INTEGER  IBID(I2,I3)
      ENDSEGMENT
      SEGMENT IZPBID
           INTEGER  IPBID(NBS)
      ENDSEGMENT
      CHARACTER*8 MTYPI,CHARI,MTYPR,CHARR
      LOGICAL LOGRE
C
C
      SEGACT MELEME
      NBSOUS=LISOUS(/1)
      NBS=NBSOUS
      IF(NBSOUS.EQ.0)NBS=1
      NVIPT=1
      IF(ITR.EQ.3)THEN
C TRANSITOIRE ON VA TROUVER UNE TABLE
           MTABLE=IPTVIT
           SEGACT MTABLE
           IVALI=1
           XVALI=0.D0
           IRETI=0
           IVALR=0
           XVALR=0.D0
           MTYPI='MOT'
           CHARR='        '
           MTYPR='TABLE'
           CALL ACCTAB(MTABLE,MTYPI,IVALI,XVALI,'TEMPS',.TRUE.,
     *      IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR)
           IF(IRETR.EQ.0)RETURN
           MTABTT=IRETR
           IVALI=1
           XVALI=0.D0
           IRETI=0
           IVALR=0
           XVALR=0.D0
           MTYPI='MOT'
           CHARR='        '
           MTYPR='TABLE'
           CALL ACCTAB(MTABLE,MTYPI,IVALI,XVALI,'VITESSE',.TRUE.,
     *      IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR)
           IF(IRETR.EQ.0)RETURN
           MTABFT=IRETR
           SEGACT MTABTT,MTABFT
           NVIPT=MTABTT.MLOTAB
      ENDIF
      SEGINI IZVIT
      SEGINI IZPBID
      IFORML=1
      CALL INITI(IDUN,NBS,0)
      CALL INITI(IPUN,NBS,0)
      CALL INITI(IPBID,NBS,0)
      IPT1=MELEME
      NBREL=0
      IF(ITR.NE.3)THEN
      MCHPO1=IPTVIT
      SEGACT MCHPO1
      SEGINI IZVPT
      IPVPT(1)=IZVPT
      NBREL=1
      SEGINI IZUMAX
      NBREL=0
      DO 50 ISOUS=1,NBS
      IF(NBSOUS.GT.0)IPT1=LISOUS(ISOUS)
      SEGACT IPT1
      MSOUPO=MCHPO1.IPCHP(1)
      SEGACT MSOUPO
      MPOVAL=IPOVAL
      SEGACT MPOVAL
      IPT2=IGEOC
      SEGACT IPT2
      NPGEO=IPT2.NUM(/2)
      I1= VPOCHA(/2)
      I2=IPT1.NUM(/1)
      I3=IPT1.NUM(/2)
C     WRITE(6,*) ' I1 I2 I3 ', I1,I2,I3
      IDUN(ISOUS)=NBREL
      ID1=NBREL
       NBREL=NBREL+I3
      SEGINI IZBID
      IPBID(ISOUS)=IZBID
C     ON A DEJA VERIFIE DANS TRJCN3 QUE LES MAILLAGES COINCIDENT
      DO 35 IEL=1,I3
      DO 30 ID=1,I2
      IBID(ID,IEL)=0
      NOE=IPT1.NUM(ID,IEL)
C      write(6,*)' noe ',noe
      DO 20 IP=1,NPGEO
      IF(NOE.EQ.IPT2.NUM(1,IP))THEN
          IBID(ID,IEL)=IP
          GO TO 25
      ENDIF
   20 CONTINUE
   25 CONTINUE
   30 CONTINUE
   35 CONTINUE
      SEGINI IZUN
      IPUN1(ISOUS)=IZUN
      SEGADJ IZUMAX
      DO 40 IEL=1,I3
      UE=0.D0
      DO 45 ID=1,I2
      IP=IBID(ID,IEL)
           DO 10 I=1,I1
           UN(I,ID,IEL)=VPOCHA(IP,I)
   10      CONTINUE
      U=0.D0
      DO 27 K=1,I1
          U=U+UN(K,ID,IEL)*UN(K,ID,IEL)
   27 CONTINUE
      U=SQRT(U)
      IF(U.GT.UE)UE=U
   45 CONTINUE
      UMAX(IEL+ID1)=UE
   40 CONTINUE
C      WRITE(6,100)(((UN(I,J,K),I=1,I1),J=1,I2),K=1,I3)
  100 FORMAT(1X,10E12.5)
       SEGDES IPT1 ,IZUN
       SEGSUP IZBID
   50 CONTINUE
      IPUMAX=IZUMAX
      SEGDES IZUMAX
      SEGDES MPOVAL ,IPT2,MSOUPO,MCHPO1,IZVPT
C     write(6,*)' idun ',(idun(i),i=1,nbs)
C
      ELSE
C                CAS D'UNE TABLE
           DO 90 KPT=1,NVIPT
           IVALI= KPT-1
           XVALI=0.D0
           IRETI=0
           IVALR=0
           XVALR=0.D0
           IRETR=0
           MTYPI='ENTIER'
           CHARI='        '
           CHARR='        '
           MTYPR='        '
           CALL ACCTAB(MTABTT,MTYPI,IVALI,XVALI,CHARI,.TRUE.,
     *      IRETI,MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR)
           TEMTRA(KPT)=XVALR
           IVALI=KPT-1
           XVALI=0.D0
           IRETI=0
           IVALR=0
           XVALR=0.D0
           MTYPI='ENTIER'
           CHARI='        '
           CHARR='        '
           MTYPR='CHPOINT'
           CALL ACCTAB(MTABFT,MTYPI,IVALI,XVALI,CHARI,.TRUE.,
     *      IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR)
           MCHPO1=IRETR
           SEGACT MCHPO1
           MSOUPO=MCHPO1.IPCHP(1)
           SEGACT MSOUPO
           MPOVAL=IPOVAL
           SEGACT MPOVAL
           SEGINI IZVPT
           IPVPT(KPT)=IZVPT
           IF(KPT.EQ.1)THEN
C   DANS CETTE BOUCLE ON INITIALISE LES TABLEAUX DE TRAVAIL
                  DO 80 ISOUS=1,NBS
                  IF(NBSOUS.GT.0)IPT1=LISOUS(ISOUS)
                  SEGACT IPT1
                  IPT2=IGEOC
                  SEGACT IPT2
                  NPGEO=IPT2.NUM(/2)
                  I1=VPOCHA(/2)
                  I2=IPT1.NUM(/1)
                  I3=IPT1.NUM(/2)
                  IDUN(ISOUS)=NBREL
                  ID1=NBREL
                   NBREL=NBREL+I3
                  SEGINI IZBID
                  IPBID(ISOUS)=IZBID
                  SEGINI IZUN
                  IPUN(ISOUS)=IZUN
                  SEGDES IZUN

C     ON A DEJA VERIFIE DANS TRJCN3 QUE LES MAILLAGES COINCIDENT
                  DO 65 IEL=1,I3
                  DO 60 ID=1,I2
                  IBID(ID,IEL)=0
                  NOE=IPT1.NUM(ID,IEL)
                  DO 70 IP=1,NPGEO
                  IF(NOE.EQ.IPT2.NUM(1,IP))THEN
                      IBID(ID,IEL)=IP
                      GO TO 55
                  ENDIF
   70             CONTINUE
   55             CONTINUE
   60             CONTINUE
   65             CONTINUE
                  SEGDES IPT1
   80             CONTINUE
            ENDIF
            SEGINI IZUMAX
            DO 85 ISOUS=1,NBS
            ID1=IDUN(ISOUS)
            SEGINI IZUN
            IPUN1(ISOUS)=IZUN
            DO 140 IEL=1,I3
            UE=0.D0
            DO 145 ID=1,I2
            IP=IBID(ID,IEL)
                 DO 110 I=1,I1
                 UN(I,ID,IEL)=VPOCHA(IP,I)
  110            CONTINUE
            U=0.D0
            DO 127 K=1,I1
                U=U+UN(K,ID,IEL)*UN(K,ID,IEL)
  127       CONTINUE
            U=SQRT(U)
            IF(U.GT.UE)UE=U
  145       CONTINUE
            UMAX(IEL+ID1)=UE
  140       CONTINUE
C      WRITE(6,100)(((UN(I,J,K),I=1,I1),J=1,I2),K=1,I3)
             SEGDES IZUN
   85       CONTINUE
            IPUMAX=IZUMAX
            SEGDES IZUMAX
            SEGDES MPOVAL ,IPT2,MSOUPO,MCHPO1
            SEGDES IZVPT
   90       CONTINUE
            DO 150 ISOUS=1,NBS
            IZBID=IPBID(ISOUS)
             SEGSUP IZBID
  150       CONTINUE
           SEGDES MTABTT,MTABFT,MTABLE
      ENDIF
      IF(NBSOUS.NE.0)SEGDES MELEME
      SEGDES IZVIT
      SEGSUP IZPBID
      RETURN
      END