Télécharger kres10.eso

Retour à la liste

Numérotation des lignes :

  1. C KRES10 SOURCE PV 16/11/17 22:00:21 9180
  2. SUBROUTINE KRES10(MRIGID,KMORS,KIZA)
  3. IMPLICIT REAL*8 (A-H,O-Z)
  4. IMPLICIT INTEGER (I-N)
  5. C***********************************************************************
  6. C NOM : KRES10
  7. C DESCRIPTION : - Conversion au format Morse de la matrice
  8. C assemblée (MMATRI)
  9. C
  10. C
  11. C LANGAGE : ESOPE
  12. C AUTEUR : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF)
  13. C mél : gounand@semt2.smts.cea.fr
  14. C***********************************************************************
  15. C VERSION : v1, 24/08/2011, version initiale
  16. C HISTORIQUE : v1, 24/08/2011, création
  17. C HISTORIQUE :
  18. C HISTORIQUE :
  19. C***********************************************************************
  20. REAL*8 XKT,PREC
  21. -INC SMRIGID
  22. -INC SMMATRI
  23. -INC CCOPTIO
  24. -INC SMLENTI
  25. POINTEUR IWORK.MLENTI
  26. SEGMENT PMORS
  27. INTEGER IA (NTT+1)
  28. INTEGER JA (NJA)
  29. ENDSEGMENT
  30. SEGMENT IZA
  31. REAL*8 A(NBVA)
  32. ENDSEGMENT
  33. POINTEUR KMORU.PMORS,KMORUT.PMORS,KMORL.PMORS,KMORS.PMORS
  34. POINTEUR KIZAU.IZA,KIZAUT.IZA,KIZAL.IZA,KIZA.IZA
  35. *
  36. SEGACT MRIGID
  37. MMATRI=ICHOLE
  38. SEGDES MRIGID
  39. SEGACT MMATRI
  40. *
  41. * WRITE(IOIMP,*) 'COUCOU KRES10'
  42. *
  43. * Transformation au format Morse du triangle inférieur IPASS=1
  44. * et supérieur IPASS=2
  45. *
  46. DO IPASS=1,2
  47. IF (IPASS.EQ.1) THEN
  48. MILIGN=IILIGN
  49. ELSE
  50. MILIGN=IILIGS
  51. ENDIF
  52. * WRITE(IOIMP,*) 'MILIGN=',MILIGN
  53. SEGACT MILIGN
  54. NNOE=ILIGN(/1)
  55. INC=IPNO(/1)
  56. * On active toutes les lignes et on compte le nombre
  57. * total de termes non nuls
  58. NJA=0
  59. DO INOE=1,NNOE
  60. LLIGN=ILIGN(INOE)
  61. SEGACT LLIGN
  62. LLVVA=XXVA(/1)
  63. NJA=NJA+LLVVA
  64. ENDDO
  65. *
  66. NTT=INC
  67. NBVA=NJA
  68. SEGINI PMORS
  69. SEGINI IZA
  70. ITT=0
  71. IJA=0
  72. IA(ITT+1)=1
  73. DO INOE=1,NNOE
  74. LLIGN=ILIGN(INOE)
  75. NA=LDEB(/1)
  76. DO INA=1,NA
  77. IVVD=IPPO(INA)
  78. IVVL=IPPO(INA+1)-IPPO(INA)
  79. ITT=ITT+1
  80. IA(ITT+1)=IA(ITT)+IVVL
  81. DO ICOP=1,IVVL
  82. IJA=IJA+1
  83. JA(IJA)=LINC(IVVD+ICOP)
  84. A(IJA)=XXVA(IVVD+ICOP)
  85. ENDDO
  86. ENDDO
  87. ENDDO
  88. SEGDES PMORS
  89. SEGDES IZA
  90. DO INOE=1,NNOE
  91. LLIGN=ILIGN(INOE)
  92. SEGDES LLIGN
  93. ENDDO
  94. * WRITE(IOIMP,*) 'MILIGN2=',MILIGN
  95. SEGDES MILIGN
  96. IF (IPASS.EQ.1) THEN
  97. KMORL=PMORS
  98. KIZAL=IZA
  99. C WRITE(IOIMP,*) 'Triangle inferieur'
  100. C CALL ECMORS(PMORS,IZA,4)
  101. ELSE
  102. KMORUT=PMORS
  103. KIZAUT=IZA
  104. C WRITE(IOIMP,*) 'Triangle superieur'
  105. C CALL ECMORS(PMORS,IZA,4)
  106. ENDIF
  107. ENDDO
  108. * On transpose le triangle supérieur
  109. SEGACT KMORUT
  110. SEGACT KIZAUT
  111. NTT=KMORUT.IA(/1)-1
  112. NJA=KMORUT.JA(/1)
  113. NBVA=NJA
  114. SEGINI KMORU
  115. SEGINI KIZAU
  116. CALL TRMORS(NTT,NJA,KIZAUT.A,KMORUT.JA,KMORUT.IA,
  117. $ KIZAU.A,KMORU.JA,KMORU.IA)
  118. SEGSUP KMORUT
  119. SEGSUP KIZAUT
  120. SEGDES KMORU
  121. SEGDES KIZAU
  122. C WRITE(IOIMP,*) 'Triangle superieur transpose'
  123. C CALL ECMORS(KMORU,KIZAU,4)
  124. *
  125. * Maintenant, on peut créer la matrice Morse total
  126. *
  127. MDIAG=IDIAG
  128. SEGACT MDIAG
  129. SEGACT KMORL
  130. SEGACT KMORU
  131. SEGACT KIZAL
  132. SEGACT KIZAU
  133. NTT=KMORU.IA(/1)-1
  134. NJAL=KMORL.JA(/1)
  135. NJAU=KMORU.JA(/1)
  136. NJA=NJAL+NTT+NJAU
  137. NBVA=NJA
  138. SEGINI PMORS
  139. SEGINI IZA
  140. NJA=0
  141. IA(1)=1
  142. DO ITT=1,NTT
  143. IAL=KMORL.IA(ITT)
  144. IALP=KMORL.IA(ITT+1)-1
  145. DO IJA=IAL,IALP
  146. IF (KMORL.JA(IJA).LT.ITT) THEN
  147. NJA=NJA+1
  148. JA(NJA)=KMORL.JA(IJA)
  149. A(NJA)=KIZAL.A(IJA)
  150. ENDIF
  151. ENDDO
  152. NJA=NJA+1
  153. JA(NJA)=ITT
  154. A(NJA)=DIAG(ITT)
  155. IAU=KMORU.IA(ITT)
  156. IAUP=KMORU.IA(ITT+1)-1
  157. DO IJA=IAU,IAUP
  158. IF (KMORU.JA(IJA).GT.ITT) THEN
  159. NJA=NJA+1
  160. JA(NJA)=KMORU.JA(IJA)
  161. A(NJA)=KIZAU.A(IJA)
  162. ENDIF
  163. ENDDO
  164. IA(ITT+1)=NJA+1
  165. ENDDO
  166. NBJA=NJA
  167. SEGADJ IZA
  168. SEGADJ PMORS
  169. SEGDES IZA
  170. SEGDES PMORS
  171. KMORS=PMORS
  172. KIZA=IZA
  173. C WRITE(IOIMP,*) 'Matrice Morse non ordonnée'
  174. C CALL ECMORS(KMORS,KIZA,4)
  175. SEGSUP KIZAU
  176. SEGSUP KMORU
  177. SEGSUP KIZAL
  178. SEGSUP KMORL
  179. SEGDES MDIAG
  180. *
  181. * Et on ordonne les colonnes si besoin
  182. * Les colonnes sont-elles ordonnées ?
  183. * Réponse : pas toujours !
  184. PMORS=KMORS
  185. IZA=KIZA
  186. SEGACT PMORS
  187. SEGACT IZA
  188. NTT=IA(/1)-1
  189. DO ITT=1,NTT
  190. IAD=IA(ITT)
  191. IAF=IA(ITT+1)-1
  192. JINI=0
  193. DO IJA=IAD,IAF
  194. JCOU=JA(IJA)
  195. IF (JCOU.LT.JINI) GOTO 30
  196. JINI=JCOU
  197. ENDDO
  198. ENDDO
  199. SEGDES PMORS
  200. SEGDES IZA
  201. * WRITE(IOIMP,*) 'Les colonnes sont ordonnees'
  202. GOTO 40
  203. *
  204. 30 CONTINUE
  205. * WRITE(IOIMP,*) 'Les colonnes ne sont pas ordonnees'
  206. SEGACT PMORS*MOD
  207. SEGACT IZA*MOD
  208. NTT=IA(/1)-1
  209. NJA=JA(/1)
  210. JG=MAX(NTT+1,2*NJA)
  211. SEGINI IWORK
  212. CALL CSORT(IA(/1)-1,A,JA,IA,
  213. $ IWORK.LECT,.TRUE.)
  214. SEGSUP IWORK
  215. SEGDES PMORS
  216. SEGDES IZA
  217. C WRITE(IOIMP,*) 'Matrice Morse ordonnée'
  218. C CALL ECMORS(PMORS,IZA,4)
  219. 40 CONTINUE
  220. RETURN
  221. END
  222.  
  223.  
  224.  
  225.  
  226.  

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