Télécharger etoile.eso

Retour à la liste

Numérotation des lignes :

  1. C ETOILE SOURCE PV 16/11/17 21:59:18 9180
  2. SUBROUTINE ETOILE(M1,M2,M3,IRET)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. C ************************************************
  6. C * Routine effectuant la multiplication de 2 *
  7. C * MATRIK sous stockage morse *
  8. C * M1 : entree *
  9. C * M2 : entree *
  10. C * M3 : Sortie sous stockage morse *
  11. C * M3 = M1 * M2 *
  12. C ************************************************
  13.  
  14. -INC SMELEME
  15. POINTEUR MELEMD.MELEME
  16.  
  17. POINTEUR M1.MATRIK,M2.MATRIK,M3.MATRIK
  18. POINTEUR PMS3.PMORS, IZA3.IZA
  19. POINTEUR IMAT1.IMATRI,IMAT2.IMATRI,IMAT3.IMATRI
  20.  
  21. INTEGER CI
  22. REAL*8 TEMP
  23.  
  24. IRET=0
  25.  
  26. SEGACT M1
  27.  
  28. C Si les matrices ne sont pas morse, on les crees
  29. C en morse
  30. IF (M1.IRIGEL(7,1).NE.6) THEN
  31. CALL ELMORS(M1,1)
  32. END IF
  33.  
  34. SEGACT M2
  35.  
  36. IF (M2.IRIGEL(7,1).NE.6) THEN
  37. CALL ELMORS(M2,1)
  38. END IF
  39.  
  40. SEGACT M1,M2
  41.  
  42. C ***********************
  43. MELEMD=M1.IRIGEL(2,1)
  44. MELEME=M2.IRIGEL(1,1)
  45.  
  46. SEGACT MELEMD,MELEME
  47. NBSOUP=MELEME.LISOUS(/1)
  48. NBSOUD=MELEMD.LISOUS(/1)
  49. SEGDES MELEMD,MELEME
  50. NMATR1=M1.IRIGEL(/2)
  51.  
  52. IF (NMATR1.GT.1) THEN
  53. WRITE(6,*) 'ETOILE: Impossible de mutiplier la'
  54. WRITE(6,*) 'matrice morse 1: NMATRI =',NMATR1,'>1.'
  55. IRET=1
  56. RETURN
  57. END IF
  58.  
  59. NMATR2=M2.IRIGEL(/2)
  60.  
  61. IF (NMATR2.GT.1) THEN
  62. WRITE(6,*) 'ETOILE: Impossible de mutiplier la'
  63. WRITE(6,*) 'matrice morse 2: NMATRI =',NMATR2,'>1.'
  64. IRET=1
  65. RETURN
  66. END IF
  67.  
  68. C ***********************
  69. C On recupere les segments necessaire pour le produit
  70.  
  71. PMS1=M1.IRIGEL(5,1)
  72. PMS2=M2.IRIGEL(5,1)
  73. IZA1=M1.IRIGEL(6,1)
  74. IZA2=M2.IRIGEL(6,1)
  75. IMAT1=M1.IRIGEL(4,1)
  76. IMAT2=M2.IRIGEL(4,1)
  77.  
  78. SEGACT IMAT1,IMAT2
  79. SEGACT PMS1,PMS2
  80. SEGACT IZA1,IZA2
  81.  
  82. C ****************************************************
  83.  
  84. NBME1=IMAT1.LIZAFM(/2)
  85. NBSOU1=IMAT1.LIZAFM(/1)
  86.  
  87. NBME2=IMAT2.LIZAFM(/2)
  88. NBSOU2=IMAT2.LIZAFM(/1)
  89.  
  90. IF (NBME1.NE.NBME2) THEN
  91. WRITE(6,*) 'ETOILE : Produit entre ces deux MATRIK'
  92. WRITE(6,*) 'incompatible'
  93. IRET=1
  94. RETURN
  95. ELSE
  96. IFLAG=0
  97. DO I=1,NBME1
  98. IF (IMAT1.LISPRI(I).NE.IMAT2.LISDUA(I)) THEN
  99. IFLAG=1
  100. END IF
  101. END DO
  102. IF (IFLAG.EQ.1) THEN
  103. WRITE(6,*) 'ETOILE : Produit entre ces deux MATRIK'
  104. WRITE(6,*) 'incompatible'
  105. IRET=1
  106. RETURN
  107. END IF
  108. END IF
  109.  
  110. NBME=NBME1
  111. NBSOUS=MAX(NBSOUP,NBSOUD)
  112. IF (NBSOUS.EQ.0) NBSOUS=1
  113.  
  114. SEGINI IMAT3
  115.  
  116. C Le primal de M3 est le primal de M2 et
  117. C le dual de M3 est le dual de M1
  118. DO I=1,NBME
  119. IMAT3.LISPRI(I)=IMAT2.LISPRI(I)
  120. IMAT3.LISDUA(I)=IMAT1.LISDUA(I)
  121. END DO
  122.  
  123. C Si Apres le produit on a plus qu'une composante en primal
  124. C ET en dual avec NBME>1 alors on ajuste a NBME=1.
  125. IF (NBME.NE.1) THEN
  126. IF ((IMAT3.LISPRI(1).EQ.IMAT3.LISPRI(2)).AND.
  127. & (IMAT3.LISDUA(1).EQ.IMAT3.LISDUA(2))) THEN
  128. NBME=1
  129. SEGADJ IMAT3
  130. END IF
  131. END IF
  132.  
  133. C On initialise M3
  134. NMATRI=1
  135. NRIGE=7
  136. NKID=9
  137. NKMT=7
  138. SEGINI M3
  139.  
  140. NTT=PMS1.IA(/1)-1
  141. NTTP=M2.KNTTP
  142.  
  143. C On initialise les segments morses de M3
  144. NJA=1
  145. NBVA=1
  146. SEGINI PMS3,IZA3
  147. M=0
  148.  
  149. C On calcule le produit:
  150. DO I=1,NTT
  151. LI1=PMS1.IA(I)
  152. NB1=PMS1.IA(I+1) - PMS1.IA(I)
  153.  
  154. DO K=1,NTTP
  155.  
  156. TEMP=0.0D0
  157. DO L=1,NB1
  158. CI=PMS1.JA(LI1+L-1)
  159.  
  160. LI2=PMS2.IA(CI)
  161. NB2=PMS2.IA(CI+1)-PMS2.IA(CI)
  162.  
  163. DO J=1,NB2
  164. IF (PMS2.JA(LI2+J-1).EQ.K) THEN
  165. TEMP=TEMP + (IZA1.A(LI1+L-1)*
  166. & IZA2.A(LI2+J-1))
  167. ELSEIF (PMS2.JA(LI2+J-1).GT.K) THEN
  168. GOTO 10
  169. END IF
  170. END DO
  171. 10 CONTINUE
  172.  
  173.  
  174. END DO
  175.  
  176. C On optimise en considerant que ce qui est < E-12 est = 0.
  177. IF (ABS(TEMP).LT.1.E-15) TEMP=0.0
  178. IF (TEMP.NE.0.0D0) THEN
  179. M=M+1
  180. 20 IF (NBVA.LT.M) THEN
  181. NBVA=NBVA+100
  182. NJA=NBVA
  183. SEGADJ IZA3,PMS3
  184. GOTO 20
  185. END IF
  186.  
  187. C remplissage ligne
  188. IF (PMS3.IA(I).EQ.0) THEN
  189. PMS3.IA(I)=M
  190. END IF
  191. C remplissage colonne
  192. PMS3.JA(M)=K
  193.  
  194. IZA3.A(M)=TEMP
  195. END IF
  196. C On fait attention aux lignes vide.
  197. IF ((PMS3.IA(I-1).EQ.0).AND.(I.NE.1)) PMS3.IA(I-1) = M+1
  198. END DO
  199. END DO
  200.  
  201. C On oublie pas de remplir la derniere ligne.
  202. PMS3.IA(NTT+1)=M+1
  203.  
  204. C on fait attention si la derniere ligne est vide.
  205. IF (PMS3.IA(NTT).EQ.0) PMS3.IA(NTT) = M+1
  206.  
  207. C On ajuste les segments morse de M3 si necessaire
  208. IF (NBVA.GT.M) THEN
  209. NBVA=M
  210. NJA=NBVA
  211. SEGADJ IZA3,PMS3
  212. END IF
  213.  
  214. C On remplit les pointeurs de M3
  215. M3.IRIGEL(5,1)=PMS3
  216. M3.IRIGEL(6,1)=IZA3
  217.  
  218. IMAT3.KSPGP=IMAT2.KSPGP
  219. IMAT3.KSPGD=IMAT1.KSPGD
  220.  
  221. M3.IRIGEL(1,1)=M2.IRIGEL(1,1)
  222. M3.IRIGEL(2,1)=M1.IRIGEL(2,1)
  223. M3.IRIGEL(4,1)=IMAT3
  224. M3.IRIGEL(7,1)=6
  225.  
  226. M3.KSYM=2
  227. M3.KNTTP=M2.KNTTP
  228. M3.KNTTD=M1.KNTTD
  229. M3.KMINCP=M2.KMINCP
  230. M3.KMINCD=M1.KMINCD
  231.  
  232. SEGDES PMS3,IZA3
  233. SEGDES PMS1,PMS2
  234. SEGDES IZA1,IZA2
  235. SEGDES M1,M2,M3
  236. SEGDES IMAT1,IMAT2,IMAT3
  237. RETURN
  238. END
  239.  
  240.  
  241.  
  242.  
  243.  
  244.  

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