Télécharger evrec6.eso

Retour à la liste

Numérotation des lignes :

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

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