Esope source files

   1 : C EVREC6    SOURCE    CHAT      11/03/16    21:21:27     6902           
   2 :       SUBROUTINE EVREC6(itap,ipmode,ipcha1,mcha,nomco,ctype,iptu,ipevo)
   3 :       IMPLICIT INTEGER(I-N)
   4 :       IMPLICIT REAL*8(A-H,O-Z)
   5 : -INC CCOPTIO 
   6 : -INC SMEVOLL  
   7 : -INC SMCHPOI
   8 : -INC SMELEME
   9 : -INC SMMODEL
  10 : -INC SMTABLE
  11 : -INC SMCHAML
  12 : -INC SMLENTI
  13 : -INC SMLREEL
  14 :       LOGICAL L0,LVAR,dix
  15 :       CHARACTER*8 CTYPE,ITYP1,CTYP,TYPRET,CHARRE
  16 :       CHARACTER*72 TI,MCHA,NOMCO
  17 :       CHARACTER*4 CMOT                                                          
  18 :       
  19 : 
  20 :       TYPRET = ' '
  20 :       CALL ACCTAB(ITAP,'MOT',I0,X0,'TEMPS',           
  21 :      &                 L0,IP0,TYPRET,I1,X1,CHARRE,LVAR,IPTEM)
  22 : 
  23 :       if (mcha(1:4).eq.'DEPL') then
  24 :         TYPRET = ' '
  24 :       CALL ACCTAB(ITAP,'MOT',I0,X0,'DEPLACEMENTS',           
  25 :      &                 L0,IP0,TYPRET,I1,X1,CHARRE,LVAR,IP1)
  26 :       else if (mcha(1:4).eq.'VITE') then
  27 :         TYPRET = ' '
  27 :       CALL ACCTAB(ITAP,'MOT',I0,X0,'VITESSES',           
  28 :      &                 L0,IP0,TYPRET,I1,X1,CHARRE,LVAR,IP1)
  29 :       else if  (mcha(1:4).eq.'ACCE') then
  30 :         TYPRET = ' '
  30 :       CALL ACCTAB(ITAP,'MOT',I0,X0,'ACCELERATIONS',           
  31 :      &                 L0,IP0,TYPRET,I1,X1,CHARRE,LVAR,IP1)
  32 :       else if  (mcha(1:4).eq.'REAC') then
  33 :         TYPRET = ' '
  33 :       CALL ACCTAB(ITAP,'MOT',I0,X0,'REACTIONS',           
  34 :      &                 L0,IP0,TYPRET,I1,X1,CHARRE,LVAR,IP1)
  35 :       else if  (mcha(1:4).eq.'CONT') then
  36 :         TYPRET = ' '
  36 :       CALL ACCTAB(ITAP,'MOT',I0,X0,'CONTRAINTES',           
  37 :      &                 L0,IP0,TYPRET,I1,X1,CHARRE,LVAR,IP1)
  38 :       else 
  39 :       endif
  40 : 
  41 :       IPX=0                                                                     
  42 :       ITOUS=0                                                                   
  43 :       ILX=0
  44 :       dix = .false.                                                                     
  44 :       CALL LIROBJ('LISTREEL',IPX,0,IRETOU)                                      
  44 :       IF(IRETOU.EQ.0) CALL LIROBJ('LISTENTI',ILX,0,IRETOU)                      
  45 :       IF(IRETOU.EQ.0) dix = .true.                                                   
  46 :       if (ilx.gt.0) then
  47 :         mlent3 = ilx
  48 :         segact mlent3
  49 :       endif
  50 :       if (ipx.gt.0) then
  51 :         mlree3 =ipx
  52 :         segact mlree3
  53 :       endif
  54 :       kix = 1
  55 : 
  55 :       call dimen7(iptem, ntemps) 
  55 :        CALL ACCTAB(IPTEM,'ENTIER',(ntemps - 1),X0,ITYP1,           
  56 :      &                 L0,IP0,'FLOTTANT',I1,XTM,CHARRE,LVAR,IP2)
  57 :       if (dix) then
  58 :         jg = ntemps
  59 :       else if (ipx.gt.0) then
  60 :         jg = mlree3.prog(/1)
  61 :       elseif (ilx.gt.0) then
  62 :         jg = mlent3.lect(/1)
  63 :       endif 
  64 :       segini mlree1
  65 :         jg0 = jg
  66 : 
  67 :       IF (CTYPE.EQ.'POINT   ') THEN                                             
  68 :          JG=1
  69 :          N = JG                                                                   
  70 :          SEGINI MLENTI,mlent1                                                           
  71 :          LECT(1)=IPTU                                                       
  72 :          jg = jg0
  73 :          segini mlreel
  74 :          mlent1.lect(1) = mlreel
  75 : *                                                                               
  76 :       ELSE IF (CTYPE.EQ.'MAILLAGE') THEN                                        
  77 :          MELEME= IPTU                                                           
  78 :          SEGACT MELEME                                                          
  78 :          IF(ITYPEL.NE.1) CALL CHANGE (IRET,1) 
  79 :          segdes meleme                                  
  80 :          MELEME=IRET                                                            
  81 :          SEGACT MELEME                                                          
  82 :          JG=NUM(/2)
  83 :          N = JG                                                              
  84 :          SEGINI MLENTI,mlent1                                                           
  85 :          DO 10 I=1,JG                                                            
  86 :             LECT(I)=NUM(1,I)                                                      
  87 :             jg = jg0
  88 :             segini mlreel
  89 :             mlent1.lect(i) = mlreel
  90 :  10      CONTINUE
  91 :          SEGSUP MELEME  
  92 :       ELSE
  93 : * cas vits
  93 :        call erreur(5)
  94 :       ENDIF
  95 : 
  96 :       kite = 0
  97 :       do ite = 0,(ntemps - 1)
  98 :        if (ilx.gt.0) then
  99 :         do jko = kix, mlent3.lect(/1)
 100 :          if (mlent3.lect(jko).eq.ite) then
 101 :            kix = jko
 102 :            dix = .true.
 103 :            goto 30
 104 :          endif
 105 :         enddo
 106 :        endif
 106 :        CALL ACCTAB(IPTEM,'ENTIER',ite,X0,ITYP1,           
 107 :      &                 L0,IP0,'FLOTTANT',I1,XT1,CHARRE,LVAR,IP2)
 108 :        if (ipx.gt.0) then
 109 :         if (kix.le.mlree3.prog(/1)) then
 110 :         do jko = kix, mlree3.prog(/1)
 111 : c         write(6,*) mlree3.prog(jko), xt1, 1.e-6*xtm,
 112 : c     &(dabs(mlree3.prog(jko) - xt1).le.1.e-6*xtm) 
 113 :          if (dabs(mlree3.prog(jko) - xt1).le.1.e-6*xtm) then
 114 :            kix = jko + 1
 115 :            dix = .true.
 116 :            goto 30
 117 :          endif
 118 :         enddo
 119 :         endif
 120 :        endif
 121 : 
 122 :  30    if (dix) then
 123 :          kite = kite + 1
 123 :        CALL ACCTAB(IP1,'ENTIER',ite,X0,ITYP1,           
 124 :      &                 L0,IP0,'CHPOINT',I1,X1,CHARRE,LVAR,IPCH1)
 125 : * recombinaison
 125 :        call recof2(ipmode,ipcha1,ipch1,ipch2)
 126 : 
 127 :         DO 41 IP=1,lect(/1)
 128 :           mpoint=lect(ip)
 129 :           CMOT=nomco(1:4)
 129 :           call EXTRA9(IPCH2,MPOINT,cmot,KERRE,XFLOT)
 130 :           mlreel = mlent1.lect(ip)
 131 :           prog(kite)=xflot
 132 :   41    continue
 133 : 
 134 :        mchpo2 = ipch2
 135 :        segsup mchpo2
 136 : 
 137 :          mlree1.prog(kite) = XT1
 138 :        endif
 139 :        if (ipx.gt.0.or.ilx.gt.0) dix = .false.
 140 :       enddo      
 141 : 
 142 :       if (kite.gt.0) then
 143 :       segini mevoll
 144 :       ipevo = mevoll
 145 :       ityevo = 'REEL'
 146 :       ievtex(1:14) = 'RECOMBINAISON '
 147 :       ievtex(15:23) = nomco(1:8)
 148 :       do jv = 1,N
 149 :         segini kevoll
 150 :         ievoll(jv) = kevoll
 151 :         iprogx = mlree1
 152 :         iprogy = mlent1.lect(jv)
 153 :         numevx = jv
 154 :         typx = 'LISTREEL'
 155 :         typy=  'LISTREEL'
 156 :         nomevx = 'TEMPS'
 157 :         nomevy = nomco(1:12) 
 158 :         segdes kevoll
 159 : 
 160 :       enddo
 161 :       segdes mevoll
 162 :       else
 163 :        ipevo = 0
 164 :       endif
 165 : 
 166 :       RETURN
 167 :       END
 168 :  
 169 :  
 170 :