Télécharger exarig.eso

Retour à la liste

Numérotation des lignes :

  1. C EXARIG SOURCE PV 16/11/26 21:15:47 9205
  2. SUBROUTINE EXARIG (ICOLAC,ITLACC,M1,M2,IIICHA)
  3. C----------------------------------------------------------------------
  4. C
  5. C BUT: REMPLIT LES PILES A PARTIR DE L EXAMEN DE LA PILE
  6. C SI IIICHA =1 ON CHANGE LES POINTEURS----
  7. C
  8. C ENTREE ITLACC PILE EXAMINEE
  9. C ICOLAC POINTEURS DES PILES A REMPLIR
  10. C M1 PREMIER INDICE D EXAMEN DANS LA PILE
  11. C M2 DERNIER INDICE
  12. C IIICHA =1 ON CHANGE LES POINTEURS
  13. C----------------------------------------------------------------
  14. C APPELE PAR EXPIL
  15. C APPELLE AJOUN
  16. C
  17. C=======================================================================
  18. C TABLEAU KCOLA :
  19. C 1 MELEME 2 CHPOIN 3 MRIGID 4 MCHAFF 5 MCHELM 6
  20. C 7 8 MSOLUT 9 MSTRUC 10 MTABLE 11 MAFFEC 12 MSOSTU
  21. C 13 IMATRI 14 MJONCT 15 MATTAC 16 MMATRI 17 MDEFOR 18 MLREEL
  22. C 19 MLENTI 20 MCHARG 21 MODELE 22 MEVOLL 23 MSUPER
  23. C=======================================================================
  24. C
  25. IMPLICIT INTEGER(I-N)
  26. IMPLICIT REAL*8(A-H,O-Z)
  27. -INC SMRIGID
  28. -INC CCOPTIO
  29. -INC TMCOLAC
  30. C **************************** MRIGID ******************************
  31. ICO1=KCOLA(1)
  32. * ICO2=KCOLA(11) ON REMPLACE PAR UN OBJET MELEME AM 12/2/90
  33. ICO3=KCOLA(13)
  34. ICO4=KCOLA(16)
  35. ICO5=KCOLA(10)
  36. ICO6=KCOLA(2)
  37. ico7=kcola(3)
  38. ILISSE=ILISSG
  39. SEGACT ILISSE*MOD
  40. 503 CONTINUE
  41.  
  42. DO 606 IEL=M1,M2
  43. MRIGID=ITLAC(IEL)
  44. IF (MRIGID.EQ.0) GO TO 606
  45. SEGACT MRIGID*MOD
  46. NRIGEL=IRIGEL(/2)
  47. DO 607 I=1,NRIGEL
  48.  
  49. C ... On rajoute le maillage sur la pile N° 1 ...
  50. IVA=IRIGEL(1,I)
  51. IF(IVA.GT.0) THEN
  52. CALL AJOUN(ICO1,IVA,ILISSE,1)
  53. IF(IIICHA.EQ.1)IRIGEL(1,I)=-IVA
  54. ENDIF
  55.  
  56. C ... On rajoute le maillage frottement sur la pile N° 1 ...
  57. IVA=IRIGEL(2,I)
  58. IF(IVA.EQ.0) GOTO 612
  59. IF(IVA.GT.0) THEN
  60. CALL AJOUN(ICO1,IVA,ILISSE,1)
  61. IF(IIICHA.EQ.1)IRIGEL(2,I)=-IVA
  62. ENDIF
  63. 612 CONTINUE
  64.  
  65. C ... On rajoute le IMATRI sur la pile N° 13 ...
  66. * IVA=IRIGEL(4,I)
  67. * IF(IVA.GT.0) THEN
  68. * CALL AJOUN(ICO3,IVA,ILISSE,1)
  69. * IF(IIICHA.EQ.1)IRIGEL(4,I)=-IVA
  70. * ENDIF
  71.  
  72. 607 CONTINUE
  73.  
  74. * NE PAS OUBLIER DE SAUVER LA TABLE SI ELLE EXISTE
  75. IF (ISUPEQ.NE.0) THEN
  76. C ... On rajoute la TABLE sur la pile N° 10 ...
  77. IVA=ISUPEQ
  78. CALL AJOUN(ICO5,IVA,ILISSE,1)
  79. IF(IIICHA.EQ.1) ISUPEQ=IVA
  80. ENDIF
  81.  
  82. IF(ICHOLE.EQ.0) GOTO 613
  83. IVA=ICHOLE
  84. IF(IVA.GT.0) THEN
  85. C ... On rajoute ICHOLE sur la pile N° 16 ...
  86. CALL AJOUN(ICO4,IVA,ILISSE,1)
  87. C ... On met le pointeur négatif pour qu'on puisse reconnaître
  88. C le pointeur sur la pile du pointeur GEMAT (voir SORTRI, WRPIL
  89. C et RESTRI) ...
  90. IF(IIICHA.EQ.1) ICHOLE=-IVA
  91. ENDIF
  92. 613 CONTINUE
  93.  
  94. IF(IMGEO1.EQ.0) GOTO 640
  95. IMGEOD=IMGEO1
  96. SEGACT IMGEOD*MOD
  97. DO 641 I=1,IMGEOR(/1)
  98. IVA=IMGEOR(I)
  99. IF(IVA.GT.0) THEN
  100. CALL AJOUN(ICO1,IVA,ILISSE,1)
  101. IF(IIICHA.EQ.1) IMGEOR(I)=-IVA
  102. ENDIF
  103. 641 CONTINUE
  104. SEGDES IMGEOD
  105. 640 CONTINUE
  106. IF(IVECRI.NE.0) THEN
  107. MVECRI=IVECRI
  108. SEGACT MVECRI*MOD
  109. DO 651 i=1,MELZON(/1)
  110. iva=melzon(i)
  111. IF(IVA.GT.0) THEN
  112. CALL AJOUN(ICO1,IVA,ILISSE,1)
  113. IF(IIICHA.EQ.1) MELZON(I)=-IVA
  114. ENDIF
  115. 651 CONTINUE
  116. SEGDES MVECRI
  117. ENDIF
  118. IF (IMGEO2.NE.0) THEN
  119. IVA=IMGEO2
  120. CALL AJOUN(ICO6,IVA,ILISSE,1)
  121. IF(IIICHA.EQ.1) IMGEO2=-IVA
  122. ENDIF
  123. if(jrcond.ne.0) then
  124. iva=jrcond
  125. call ajoun(ico7,iva,ilisse,1)
  126. if(iiicha.eq.1) jrcond= -iva
  127. endif
  128. if(jrdepp.ne.0) then
  129. iva=jrdepp
  130. call ajoun(ico7,iva,ilisse,1)
  131. if(iiicha.eq.1) jrdepp= -iva
  132. endif
  133. if(jrdepd.ne.0) then
  134. iva=jrdepd
  135. call ajoun(ico7,iva,ilisse,1)
  136. if(iiicha.eq.1) jrdepd= -iva
  137. endif
  138. if(jrelim.ne.0) then
  139. iva=jrelim
  140. call ajoun(ico7,iva,ilisse,1)
  141. if(iiicha.eq.1) jrelim= -iva
  142. endif
  143. if(jrgard.ne.0) then
  144. iva=jrgard
  145. call ajoun(ico7,iva,ilisse,1)
  146. if(iiicha.eq.1) jrgard= -iva
  147. endif
  148. if(jrtot.ne.0) then
  149. iva=jrtot
  150. call ajoun(ico7,iva,ilisse,1)
  151. if(iiicha.eq.1) jrtot= -iva
  152. endif
  153. if(imlag.ne.0) then
  154. * write (6,*) ' dans exarig ',imlag
  155. iva=imlag
  156. call ajoun(ico1,iva,ilisse,1)
  157. if(iiicha.eq.1) imlag= -iva
  158. endif
  159. SEGDES MRIGID
  160. 606 CONTINUE
  161. GO TO 599
  162. C*********************************************************************
  163. 599 CONTINUE
  164. * SEGDES ILISSE
  165. RETURN
  166. END
  167.  
  168.  
  169.  
  170.  
  171.  
  172.  
  173.  
  174.  
  175.  
  176.  
  177.  
  178.  
  179.  
  180.  

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