Télécharger evol2.eso

Retour à la liste

Numérotation des lignes :

  1. C EVOL2 SOURCE FANDEUR 10/12/14 21:16:15 6812
  2. SUBROUTINE EVOL2(IBOO,ILEX,IBOBAS,ICHAN)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. C=======================================================================
  6. C ILEX CONTIENT LA SUITE DES CHPOINTS DES CONTRIBUTIONS MODALES.
  7. C POUR LES COUPLES POINTS-COMPOSANTES CONTENUS DANS NUMOO, ON
  8. C RECOMBINE LES MODES ET SOLUTIONS STATIQUES CONTENUS DANS MSOBAS .
  9. C RESULTAT DANS LE(S) LISTREEL KLIST.
  10. C APPELE PAR EVRECO
  11. C SI ICHAN=0 ON TRAVAILLE SUR UN CHPOINT
  12. C SI ICHAN=1 ON TRAVAILLE SUR UN CHAMELEM ET ON LE TRANSFORME EN
  13. C CHPOINT PAR UN APPEL A PELPO
  14. C APPELLE : ERREUR(61,243,18) IANUL PROSC1
  15. C CREATION : 02/04/85
  16. C PROGRAMMEUR : FARVACQUE
  17. C=======================================================================
  18. C
  19. -INC CCOPTIO
  20. -INC SMBASEM
  21. -INC SMCHPOI
  22. -INC SMSOLUT
  23. -INC SMLREEL
  24. -INC SMELEME
  25. -INC SMCOORD
  26. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  27. SEGMENT ICPR1(XCOOR(/1)/(IDIM+1))
  28. SEGMENT/ITRAV1/( TRAV(LDEPL,N)*D)
  29. SEGMENT/ITRAV2/(TRAVV(LDEPL)*D)
  30. SEGMENT/ITRAV3/(ICC(N),ISS(N),IPP(N),NBB(N))
  31. SEGMENT IPOS(NSOUP1)
  32. SEGMENT ITRAV(2,LDEPL)
  33. SEGMENT NUMOO
  34. INTEGER NUMO(N),KLIST(N)
  35. CHARACTER*4 NUDDL(N)
  36. ENDSEGMENT
  37. DIMENSION KDEPL(2),IMEL(2)
  38. CHARACTER*4 NUJ
  39. C
  40. NUMOO=IBOO
  41. SEGACT NUMOO
  42. N=NUMO(/1)
  43. MSOBAS=IBOBAS
  44. SEGACT MSOBAS
  45. LDEPL=0
  46. DO 6 ICAS=1,2
  47. KDEPL(ICAS)=0
  48. MSOLUT=IBSTRM(ICAS+1)
  49. IF(MSOLUT.EQ.0) GOTO 6
  50. SEGACT MSOLUT
  51. IF (ICHAN.EQ.0) KDEPL(ICAS)=MSOLIS(5)
  52. IF (ICHAN.EQ.1) KDEPL(ICAS)=MSOLIS(6)
  53. IMEL(ICAS)=MSOLIS(3)
  54. SEGDES MSOLUT
  55. IF(KDEPL(ICAS).EQ.0) THEN
  56. MOTERR(1:8)=ITYSOL
  57. CALL ERREUR(61)
  58. SEGDES MSOBAS
  59. RETURN
  60. ENDIF
  61. MSOLEN=KDEPL(ICAS)
  62. SEGACT MSOLEN
  63. LDEPL=LDEPL+ISOLEN(/1)
  64. SEGDES MSOLEN
  65. 6 CONTINUE
  66. SEGDES MSOBAS
  67. LICPR=XCOOR(/1)/(IDIM+1)
  68. SEGINI ICPR,ICPR1
  69. C
  70. C **** FABRICATION DU TABLEAU ICC-ISS-IPP-NBB POUR CHAQUE PT DE SORTIE
  71. C **** (BOUCLE 30)
  72. C **** FABRICATION DU TABLEAU TRAV(LDEPL,N) DES MODES REDUITS AUX
  73. C **** POINTS DE SORTIE (BOUCLE 40)
  74. C
  75. JJJ=0
  76. SEGINI ITRAV1
  77. DO 50 ICAS=1,2
  78. MSOLEN=KDEPL(ICAS)
  79. IF(MSOLEN.EQ.0) GOTO 50
  80. SEGINI ITRAV3
  81. SEGACT MSOLEN
  82. IF (ICHAN.EQ.0) THEN
  83. MCHPOI=ISOLEN(1)
  84. ELSE
  85. ICHAM=ISOLEN(1)
  86. C* Manque le passage en MCHAML aux noeuds avec le modele !!!
  87. C* CALL CHASUP(IPMODL,ICHAM,ICHAM2,IRET,1)
  88. C* IF (IRET.EQ.0) THEN
  89. C* CALL ERREUR(___)
  90. C* RETURN
  91. C* ENDIF
  92. C* CALL CHAMPO(ICHAM2,2,MCHPOI,IRET)
  93. CALL CHAMPO(ICHAM,2,MCHPOI,IRET)
  94. IF (IRET.EQ.0) RETURN
  95. ENDIF
  96. SEGACT MCHPOI
  97. NSOUPO=IPCHP(/1)
  98. KK=0
  99. DO 30 ISOU=1,NSOUPO
  100. MSOUPO=IPCHP(ISOU)
  101. SEGACT MSOUPO
  102. NC=NOCOMP(/2)
  103. MELEME=IGEOC
  104. SEGACT MELEME
  105. CALL IANUL(ICPR(1),LICPR)
  106. DO 60 NB=1,NUM(/2)
  107. ICPR(NUM(1,NB))=NB
  108. 60 CONTINUE
  109. SEGDES MELEME
  110. DO 61 I=1,N
  111. IF(ICPR(NUMO(I)).NE.0) THEN
  112. KK=KK+1
  113. NBB(KK)=ICPR(NUMO(I))
  114. NUJ=NUDDL(I)
  115. DO 72 IC=1,NC
  116. IF(NOCOMP(IC).EQ.NUJ) THEN
  117. ICC(KK)=IC
  118. ISS(KK)=ISOU
  119. IPP(KK)=I
  120. GOTO 61
  121. ENDIF
  122. 72 CONTINUE
  123. MOTERR(1:4)=NUJ
  124. CALL ERREUR(243)
  125. C INCOMPATIBILITE POINT_COMPOSANTE
  126. GOTO 5000
  127. ENDIF
  128. 61 CONTINUE
  129. SEGDES MSOUPO
  130. 30 CONTINUE
  131. C
  132. IF(KK.NE.N) THEN
  133. CALL ERREUR(18)
  134. C IL MANQUE DES POINTS
  135. GOTO 5000
  136. ENDIF
  137. C
  138. LDEP=ISOLEN(/1)
  139. MELEME=IMEL(ICAS)
  140. SEGACT MELEME
  141. DO 40 I=1,LDEP
  142. JJJ=JJJ+1
  143. ICPR1(NUM(1,I))=JJJ
  144. IF(I.EQ.1) GOTO 42
  145. IF (ICHAN.EQ.0) THEN
  146. MCHPOI=ISOLEN(I)
  147. ELSE
  148. ICHAM=ISOLEN(I)
  149. C* Manque le passage en MCHAML aux noeuds avec le modele !!!
  150. C* CALL CHASUP(IPMODL,ICHAM,ICHAM2,IRET,1)
  151. C* IF (IRET.EQ.0) THEN
  152. C* CALL ERREUR(___)
  153. C* RETURN
  154. C* ENDIF
  155. C* CALL CHAMPO(ICHAM2,2,MCHPOI,IRET)
  156. CALL CHAMPO(ICHAM,2,MCHPOI,IRET)
  157. IF (IRET.EQ.0) RETURN
  158. ENDIF
  159. SEGACT MCHPOI
  160. 42 CONTINUE
  161. DO 41 IP=1,N
  162. MSOUPO=IPCHP(ISS(IP))
  163. SEGACT MSOUPO
  164. MPOVAL=IPOVAL
  165. SEGACT MPOVAL
  166. TRAV(JJJ,IPP(IP))=VPOCHA(NBB(IP),ICC(IP))
  167. SEGDES MPOVAL,MSOUPO
  168. 41 CONTINUE
  169. IF (ICHAN.EQ.0) SEGDES MCHPOI
  170. IF (ICHAN.EQ.1) SEGSUP MCHPOI
  171. 40 CONTINUE
  172. SEGDES MSOLEN,MELEME
  173. SEGSUP ITRAV3
  174. 50 CONTINUE
  175. C
  176. SEGSUP ICPR
  177. C
  178. C **** FABRICATION DE ITRAV(2,LDEPL), ET DE IPOS(NSOUP+1)
  179. C
  180. MSOLEN=ILEX
  181. SEGACT MSOLEN
  182. MCHPOI=ISOLEN(1)
  183. SEGACT MCHPOI
  184. NSOUP=IPCHP(/1)
  185. NSOUP1=NSOUP+1
  186. SEGINI IPOS
  187. SEGINI ITRAV
  188. KK=0
  189. IPOS(1)=0
  190. DO 1 ISOU=1,NSOUP
  191. MSOUPO=IPCHP(ISOU)
  192. SEGACT MSOUPO
  193. MELEME=IGEOC
  194. SEGACT MELEME
  195. DO 2 I=1,NUM(/2)
  196. J=ICPR1(NUM(1,I))
  197. IF(J.NE.0) THEN
  198. KK=KK+1
  199. ITRAV(1,KK)=I
  200. ITRAV(2,KK)=J
  201. ENDIF
  202. 2 CONTINUE
  203. SEGDES MELEME,MSOUPO
  204. IPOS(ISOU+1)=KK
  205. 1 CONTINUE
  206. SEGSUP ICPR1
  207. C
  208. C **** BOUCLE SUR LES INSTANTS DE LA TABLE
  209. C
  210. MSOLEN=ILEX
  211. SEGACT MSOLEN
  212. LTEM=ISOLEN(/1)
  213. JG=LTEM
  214. DO 99 JJ=1,N
  215. SEGINI MLREEL
  216. KLIST(JJ)=MLREEL
  217. 99 CONTINUE
  218. C
  219. SEGINI ITRAV2
  220. DO 90 L=1,LTEM
  221. MCHPOI=ISOLEN(L)
  222. SEGACT MCHPOI
  223. DO 70 I=1,NSOUP
  224. IF(IPOS(I+1).NE.IPOS(I)) THEN
  225. MSOUPO=IPCHP(I)
  226. SEGACT MSOUPO
  227. MPOVAL=IPOVAL
  228. SEGACT MPOVAL
  229. DO 160 NB=IPOS(I)+1,IPOS(I+1)
  230. TRAVV(ITRAV(2,NB))=VPOCHA(ITRAV(1,NB),1)
  231. 160 CONTINUE
  232. SEGDES MPOVAL,MSOUPO
  233. ENDIF
  234. 70 CONTINUE
  235. SEGDES MCHPOI
  236. DO 162 IP=1,N
  237. CALL PROSC1(TRAVV,TRAV(1,IP),RET,LDEPL)
  238. MLREEL=KLIST(IP)
  239. PROG(L)=RET
  240. 162 CONTINUE
  241. 90 CONTINUE
  242. C
  243. SEGSUP ITRAV
  244. SEGSUP IPOS
  245. SEGSUP ITRAV1,ITRAV2
  246. DO 98 JJ=1,N
  247. MLREEL=KLIST(JJ)
  248. SEGDES MLREEL
  249. 98 CONTINUE
  250. C
  251. SEGDES MSOLEN
  252. 5000 CONTINUE
  253. RETURN
  254. END
  255.  
  256.  
  257.  

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