Télécharger exarig.eso

Retour à la liste

Numérotation des lignes :

exarig
  1. C EXARIG SOURCE PV 21/01/21 21:15:20 10862
  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.  
  29. -INC PPARAM
  30. -INC CCOPTIO
  31. -INC TMCOLAC
  32. iun=1
  33. C **************************** MRIGID ******************************
  34. ICO1=KCOLA(1)
  35. * ICO2=KCOLA(11) ON REMPLACE PAR UN OBJET MELEME AM 12/2/90
  36. ICO3=KCOLA(13)
  37. ICO4=KCOLA(16)
  38. ICO5=KCOLA(10)
  39. ICO6=KCOLA(2)
  40. ico7=kcola(3)
  41. ILISSE=ILISSG
  42. SEGACT ILISSE*MOD
  43. 503 CONTINUE
  44.  
  45. DO 606 IEL=M1,M2
  46. MRIGID=ITLAC(IEL)
  47. IF (MRIGID.EQ.0) GO TO 606
  48. SEGACT MRIGID*MOD
  49. NRIGEL=IRIGEL(/2)
  50. DO 607 I=1,NRIGEL
  51.  
  52. C ... On rajoute le maillage sur la pile N° 1 ...
  53. IVA=IRIGEL(1,I)
  54. IF(IVA.GT.0) THEN
  55. CALL AJOUN(ICO1,IVA,ILISSE,iun)
  56. IF(IIICHA.EQ.1)IRIGEL(1,I)=-IVA
  57. ENDIF
  58.  
  59. C ... On rajoute le maillage frottement sur la pile N° 1 ...
  60. IVA=IRIGEL(2,I)
  61. IF(IVA.EQ.0) GOTO 612
  62. IF(IVA.GT.0) THEN
  63. CALL AJOUN(ICO1,IVA,ILISSE,iun)
  64. IF(IIICHA.EQ.1)IRIGEL(2,I)=-IVA
  65. ENDIF
  66. 612 CONTINUE
  67.  
  68. C ... On rajoute le IMATRI sur la pile N° 13 ...
  69. IVA=IRIGEL(4,I)
  70. if (iiicha.eq.1) then
  71. * en menage on n'active pas xmatri
  72. XMATRI=IRIGEL(4,I)
  73. SEGACT xmatri*mod
  74. symre = irigel(7,I)
  75. segdes xmatri
  76. endif
  77. if (ionive.ge.20) then
  78. IF(IVA.GT.0) THEN
  79. CALL AJOUN(ICO3,IVA,ILISSE,iun)
  80. IF(IIICHA.EQ.1)IRIGEL(4,I)=-IVA
  81. ENDIF
  82. endif
  83.  
  84. 607 CONTINUE
  85.  
  86. * NE PAS OUBLIER DE SAUVER LA TABLE SI ELLE EXISTE
  87. IF (ISUPEQ.NE.0) THEN
  88. C ... On rajoute la TABLE sur la pile N° 10 ...
  89. IVA=ISUPEQ
  90. CALL AJOUN(ICO5,IVA,ILISSE,iun)
  91. IF(IIICHA.EQ.1) ISUPEQ=IVA
  92. ENDIF
  93.  
  94. IF(ICHOLE.EQ.0) GOTO 613
  95. IVA=ICHOLE
  96. IF(IVA.GT.0) THEN
  97. C ... On rajoute ICHOLE sur la pile N° 16 ...
  98. CALL AJOUN(ICO4,IVA,ILISSE,iun)
  99. C ... On met le pointeur négatif pour qu'on puisse reconnaître
  100. C le pointeur sur la pile du pointeur GEMAT (voir SORTRI, WRPIL
  101. C et RESTRI) ...
  102. IF(IIICHA.EQ.1) ICHOLE=-IVA
  103. ENDIF
  104. 613 CONTINUE
  105.  
  106. IF(IMGEO1.EQ.0) GOTO 640
  107. IMGEOD=IMGEO1
  108. SEGACT IMGEOD*MOD
  109. DO 641 I=1,IMGEOR(/1)
  110. IVA=IMGEOR(I)
  111. IF(IVA.GT.0) THEN
  112. CALL AJOUN(ICO1,IVA,ILISSE,iun)
  113. IF(IIICHA.EQ.1) IMGEOR(I)=-IVA
  114. ENDIF
  115. 641 CONTINUE
  116. SEGDES IMGEOD
  117. 640 CONTINUE
  118. IF(IVECRI.NE.0) THEN
  119. MVECRI=IVECRI
  120. SEGACT MVECRI*MOD
  121. DO 651 i=1,MELZON(/1)
  122. iva=melzon(i)
  123. IF(IVA.GT.0) THEN
  124. CALL AJOUN(ICO1,IVA,ILISSE,iun)
  125. IF(IIICHA.EQ.1) MELZON(I)=-IVA
  126. ENDIF
  127. 651 CONTINUE
  128. SEGDES MVECRI
  129. ENDIF
  130. IF (IMGEO2.NE.0) THEN
  131. IVA=IMGEO2
  132. CALL AJOUN(ICO6,IVA,ILISSE,iun)
  133. IF(IIICHA.EQ.1) IMGEO2=-IVA
  134. ENDIF
  135. if(jrcond.ne.0) then
  136. iva=jrcond
  137. call ajoun(ico7,iva,ilisse,iun)
  138. if(iiicha.eq.1) jrcond= -iva
  139. endif
  140. if(jrsup.ne.0) then
  141. iva=jrsup
  142. call ajoun(ico7,iva,ilisse,iun)
  143. if(iiicha.eq.1) jrsup= -iva
  144. endif
  145. if(jrdepp.ne.0) then
  146. iva=jrdepp
  147. call ajoun(ico7,iva,ilisse,iun)
  148. if(iiicha.eq.1) jrdepp= -iva
  149. endif
  150. if(jrdepd.ne.0) then
  151. iva=jrdepd
  152. call ajoun(ico7,iva,ilisse,iun)
  153. if(iiicha.eq.1) jrdepd= -iva
  154. endif
  155. if(jrelim.ne.0) then
  156. iva=jrelim
  157. call ajoun(ico7,iva,ilisse,iun)
  158. if(iiicha.eq.1) jrelim= -iva
  159. endif
  160. if(jrgard.ne.0) then
  161. iva=jrgard
  162. call ajoun(ico7,iva,ilisse,iun)
  163. if(iiicha.eq.1) jrgard= -iva
  164. endif
  165. if(jrtot.ne.0) then
  166. iva=jrtot
  167. call ajoun(ico7,iva,ilisse,iun)
  168. if(iiicha.eq.1) jrtot= -iva
  169. endif
  170. if(imlag.ne.0) then
  171. * write (6,*) ' dans exarig ',imlag
  172. iva=imlag
  173. call ajoun(ico1,iva,ilisse,iun)
  174. if(iiicha.eq.1) imlag= -iva
  175. endif
  176. SEGDES MRIGID
  177. 606 CONTINUE
  178. GO TO 599
  179. C*********************************************************************
  180. 599 CONTINUE
  181. * SEGDES ILISSE
  182. RETURN
  183. END
  184.  
  185.  
  186.  
  187.  
  188.  
  189.  
  190.  
  191.  
  192.  
  193.  
  194.  
  195.  
  196.  
  197.  
  198.  
  199.  
  200.  
  201.  
  202.  

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