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

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