Télécharger kres10.eso

Retour à la liste

Numérotation des lignes :

  1. C KRES10 SOURCE GOUNAND 19/07/03 21:15:01 10248
  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. *dbg WRITE(IOIMP,*) ' KRES10 INC=',INC
  67. NTT=INC
  68. NBVA=NJA
  69. SEGINI PMORS
  70. SEGINI IZA
  71. ITT=0
  72. IJA=0
  73. IA(ITT+1)=1
  74. DO INOE=1,NNOE
  75. LLIGN=ILIGN(INOE)
  76. NA=LDEB(/1)
  77. DO INA=1,NA
  78. IVVD=IPPO(INA)
  79. IVVL=IPPO(INA+1)-IPPO(INA)
  80. ITT=ITT+1
  81. IA(ITT+1)=IA(ITT)+IVVL
  82. DO ICOP=1,IVVL
  83. IJA=IJA+1
  84. JA(IJA)=LINC(IVVD+ICOP)
  85. A(IJA)=XXVA(IVVD+ICOP)
  86. ENDDO
  87. ENDDO
  88. ENDDO
  89. SEGDES PMORS
  90. SEGDES IZA
  91. DO INOE=1,NNOE
  92. LLIGN=ILIGN(INOE)
  93. SEGDES LLIGN
  94. ENDDO
  95. * WRITE(IOIMP,*) 'MILIGN2=',MILIGN
  96. SEGDES MILIGN
  97. IF (IPASS.EQ.1) THEN
  98. KMORL=PMORS
  99. KIZAL=IZA
  100. C WRITE(IOIMP,*) 'Triangle inferieur'
  101. C CALL ECMORS(PMORS,IZA,4)
  102. ELSE
  103. KMORUT=PMORS
  104. KIZAUT=IZA
  105. C WRITE(IOIMP,*) 'Triangle superieur'
  106. C CALL ECMORS(PMORS,IZA,4)
  107. ENDIF
  108. ENDDO
  109. * On transpose le triangle supérieur
  110. SEGACT KMORUT
  111. SEGACT KIZAUT
  112. NTT=KMORUT.IA(/1)-1
  113. NJA=KMORUT.JA(/1)
  114. NBVA=NJA
  115. SEGINI KMORU
  116. SEGINI KIZAU
  117. CALL TRMORS(NTT,NJA,KIZAUT.A,KMORUT.JA,KMORUT.IA,
  118. $ KIZAU.A,KMORU.JA,KMORU.IA)
  119. SEGSUP KMORUT
  120. SEGSUP KIZAUT
  121. SEGDES KMORU
  122. SEGDES KIZAU
  123. C WRITE(IOIMP,*) 'Triangle superieur transpose'
  124. C CALL ECMORS(KMORU,KIZAU,4)
  125. *
  126. * Maintenant, on peut créer la matrice Morse total
  127. *
  128. MDIAG=IDIAG
  129. SEGACT MDIAG
  130. SEGACT KMORL
  131. SEGACT KMORU
  132. SEGACT KIZAL
  133. SEGACT KIZAU
  134. NTT=KMORU.IA(/1)-1
  135. NJAL=KMORL.JA(/1)
  136. NJAU=KMORU.JA(/1)
  137. NJA=NJAL+NTT+NJAU
  138. NBVA=NJA
  139. SEGINI PMORS
  140. SEGINI IZA
  141. NJA=0
  142. IA(1)=1
  143. DO ITT=1,NTT
  144. IAL=KMORL.IA(ITT)
  145. IALP=KMORL.IA(ITT+1)-1
  146. DO IJA=IAL,IALP
  147. IF (KMORL.JA(IJA).LT.ITT) THEN
  148. NJA=NJA+1
  149. JA(NJA)=KMORL.JA(IJA)
  150. A(NJA)=KIZAL.A(IJA)
  151. ENDIF
  152. ENDDO
  153. NJA=NJA+1
  154. JA(NJA)=ITT
  155. A(NJA)=DIAG(ITT)
  156. IAU=KMORU.IA(ITT)
  157. IAUP=KMORU.IA(ITT+1)-1
  158. DO IJA=IAU,IAUP
  159. IF (KMORU.JA(IJA).GT.ITT) THEN
  160. NJA=NJA+1
  161. JA(NJA)=KMORU.JA(IJA)
  162. A(NJA)=KIZAU.A(IJA)
  163. ENDIF
  164. ENDDO
  165. IA(ITT+1)=NJA+1
  166. ENDDO
  167. *inutile NBJA=NJA
  168. SEGADJ IZA
  169. SEGADJ PMORS
  170. SEGDES IZA
  171. SEGDES PMORS
  172. KMORS=PMORS
  173. KIZA=IZA
  174. C WRITE(IOIMP,*) 'Matrice Morse non ordonnée'
  175. C CALL ECMORS(KMORS,KIZA,4)
  176. SEGSUP KIZAU
  177. SEGSUP KMORU
  178. SEGSUP KIZAL
  179. SEGSUP KMORL
  180. SEGDES MDIAG
  181. *
  182. * Et on ordonne les colonnes si besoin
  183. * Les colonnes sont-elles ordonnées ?
  184. * Réponse : pas toujours !
  185. PMORS=KMORS
  186. IZA=KIZA
  187. SEGACT PMORS
  188. SEGACT IZA
  189. NTT=IA(/1)-1
  190. DO ITT=1,NTT
  191. IAD=IA(ITT)
  192. IAF=IA(ITT+1)-1
  193. JINI=0
  194. DO IJA=IAD,IAF
  195. JCOU=JA(IJA)
  196. IF (JCOU.LT.JINI) GOTO 30
  197. JINI=JCOU
  198. ENDDO
  199. ENDDO
  200. SEGDES PMORS
  201. SEGDES IZA
  202. * WRITE(IOIMP,*) 'Les colonnes sont ordonnees'
  203. GOTO 40
  204. *
  205. 30 CONTINUE
  206. * WRITE(IOIMP,*) 'Les colonnes ne sont pas ordonnees'
  207. SEGACT PMORS*MOD
  208. SEGACT IZA*MOD
  209. NTT=IA(/1)-1
  210. NJA=JA(/1)
  211. JG=MAX(NTT+1,2*NJA)
  212. SEGINI IWORK
  213. CALL CSORT(IA(/1)-1,A,JA,IA,
  214. $ IWORK.LECT,.TRUE.)
  215. SEGSUP IWORK
  216. SEGDES PMORS
  217. SEGDES IZA
  218. C WRITE(IOIMP,*) 'Matrice Morse ordonnée'
  219. C CALL ECMORS(PMORS,IZA,4)
  220. 40 CONTINUE
  221. RETURN
  222. END
  223.  
  224.  
  225.  
  226.  
  227.  
  228.  

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