Télécharger evrec6.eso

Retour à la liste

evrec6
C EVREC6    SOURCE    CB215821  24/04/12    21:15:49     11897          
      SUBROUTINE EVREC6(itap,ipmode,ipcha1,mcha,nomco,ctype,iptu,ipevo)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
-INC SMEVOLL
-INC SMCHPOI
-INC SMELEME
-INC SMMODEL
-INC SMTABLE
-INC SMCHAML
-INC SMLENTI
-INC SMLREEL
      LOGICAL L0,LVAR,dix
      CHARACTER*8 CTYPE,ITYP1,CTYP,TYPRET,CHARRE
      CHARACTER*72 TI,MCHA,NOMCO
      CHARACTER*4 CMOT
 
 
      TYPRET = ' '
      CALL ACCTAB(ITAP,'MOT',I0,X0,'TEMPS',
     &                 L0,IP0,TYPRET,I1,X1,CHARRE,LVAR,IPTEM)
 
      if (mcha(1:4).eq.'DEPL') then
        TYPRET = ' '
      CALL ACCTAB(ITAP,'MOT',I0,X0,'DEPLACEMENTS',
     &                 L0,IP0,TYPRET,I1,X1,CHARRE,LVAR,IP1)
      else if (mcha(1:4).eq.'VITE') then
        TYPRET = ' '
      CALL ACCTAB(ITAP,'MOT',I0,X0,'VITESSES',
     &                 L0,IP0,TYPRET,I1,X1,CHARRE,LVAR,IP1)
      else if  (mcha(1:4).eq.'ACCE') then
        TYPRET = ' '
      CALL ACCTAB(ITAP,'MOT',I0,X0,'ACCELERATIONS',
     &                 L0,IP0,TYPRET,I1,X1,CHARRE,LVAR,IP1)
      else if  (mcha(1:4).eq.'REAC') then
        TYPRET = ' '
      CALL ACCTAB(ITAP,'MOT',I0,X0,'REACTIONS',
     &                 L0,IP0,TYPRET,I1,X1,CHARRE,LVAR,IP1)
      else if  (mcha(1:4).eq.'CONT') then
        TYPRET = ' '
      CALL ACCTAB(ITAP,'MOT',I0,X0,'CONTRAINTES',
     &                 L0,IP0,TYPRET,I1,X1,CHARRE,LVAR,IP1)
      else
      endif
 
      IPX=0
      ITOUS=0
      ILX=0
      dix = .false.
      CALL LIROBJ('LISTREEL',IPX,0,IRETOU)
      IF(IRETOU.EQ.0) CALL LIROBJ('LISTENTI',ILX,0,IRETOU)
      IF(IRETOU.EQ.0) dix = .true.
      if (ilx.gt.0) then
        mlent3 = ilx
        segact mlent3
      endif
      if (ipx.gt.0) then
        mlree3 =ipx
        segact mlree3
      endif
      kix = 1
 
      call dimen7(iptem, ntemps)
       CALL ACCTAB(IPTEM,'ENTIER',(ntemps - 1),X0,ITYP1,
     &                 L0,IP0,'FLOTTANT',I1,XTM,CHARRE,LVAR,IP2)
      if (dix) then
        jg = ntemps
      else if (ipx.gt.0) then
        jg = mlree3.prog(/1)
      elseif (ilx.gt.0) then
        jg = mlent3.lect(/1)
      endif
      segini mlree1
        jg0 = jg
 
      IF (CTYPE.EQ.'POINT   ') THEN
         JG=1
         N = JG
         SEGINI MLENTI,mlent1
         LECT(1)=IPTU
         jg = jg0
         segini mlreel
         mlent1.lect(1) = mlreel
*
      ELSE IF (CTYPE.EQ.'MAILLAGE') THEN
         MELEME= IPTU
         SEGACT MELEME
         IF(ITYPEL.NE.1) CALL CHANGE (IRET,1)
         segdes meleme
         MELEME=IRET
         SEGACT MELEME
         JG=NUM(/2)
         N = JG
         SEGINI MLENTI,mlent1
         DO 10 I=1,JG
            LECT(I)=NUM(1,I)
            jg = jg0
            segini mlreel
            mlent1.lect(i) = mlreel
 10      CONTINUE
         SEGSUP MELEME
      ELSE
* cas vits
       call erreur(5)
      ENDIF
 
      kite = 0
      do ite = 0,(ntemps - 1)
       if (ilx.gt.0) then
        do jko = kix, mlent3.lect(/1)
         if (mlent3.lect(jko).eq.ite) then
           kix = jko
           dix = .true.
           goto 30
         endif
        enddo
       endif
       CALL ACCTAB(IPTEM,'ENTIER',ite,X0,ITYP1,
     &                 L0,IP0,'FLOTTANT',I1,XT1,CHARRE,LVAR,IP2)
       if (ipx.gt.0) then
        if (kix.le.mlree3.prog(/1)) then
        do jko = kix, mlree3.prog(/1)
c         write(6,*) mlree3.prog(jko), xt1, 1.e-6*xtm,
c     &(ABS(mlree3.prog(jko) - xt1).le.1.e-6*xtm)
         if (ABS(mlree3.prog(jko) - xt1).le.1.e-6*xtm) then
           kix = jko + 1
           dix = .true.
           goto 30
         endif
        enddo
        endif
       endif
 
 30    if (dix) then
         kite = kite + 1
       CALL ACCTAB(IP1,'ENTIER',ite,X0,ITYP1,
     &                 L0,IP0,'CHPOINT',I1,X1,CHARRE,LVAR,IPCH1)
* recombinaison
       call recof2(ipmode,ipcha1,ipch1,ipch2)
 
        DO 41 IP=1,lect(/1)
          mpoint=lect(ip)
          CMOT=nomco(1:4)
          call EXTRA9(IPCH2,MPOINT,cmot,0,.FALSE.,XFLOT,IRET)
          mlreel = mlent1.lect(ip)
          prog(kite)=xflot
  41    continue
 
       mchpo2 = ipch2
       segsup mchpo2
 
         mlree1.prog(kite) = XT1
       endif
       if (ipx.gt.0.or.ilx.gt.0) dix = .false.
      enddo
 
      if (kite.gt.0) then
      segini mevoll
      ipevo = mevoll
      ityevo = 'REEL'
      ievtex(1:14) = 'RECOMBINAISON '
      ievtex(15:23) = nomco(1:8)
      do jv = 1,N
        segini kevoll
        ievoll(jv) = kevoll
        iprogx = mlree1
        iprogy = mlent1.lect(jv)
        numevx = jv
        typx = 'LISTREEL'
        typy=  'LISTREEL'
        nomevx = 'TEMPS'
        nomevy = nomco(1:12)
        segdes kevoll
 
      enddo
      segdes mevoll
      else
       ipevo = 0
      endif
 
      RETURN
      END
 
 
 
 
 
 
 
 
 

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