Télécharger addmat.eso

Retour à la liste

Numérotation des lignes :

  1. C ADDMAT SOURCE PV 16/11/17 21:58:05 9180
  2. SUBROUTINE ADDMAT(M1,M2,M3,IRET)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5.  
  6. POINTEUR M1.MATRIK,M2.MATRIK,M3.MATRIK
  7. POINTEUR PMS3.PMORS, IZA3.IZA
  8. POINTEUR IMAT1.IMATRI,IMAT2.IMATRI,IMAT3.IMATRI
  9.  
  10. SEGMENT ASSTAB
  11. INTEGER ITAB(NBCOMP,NTA)
  12. ENDSEGMENT
  13.  
  14. INTEGER NBCOMP,NTA,PRI,DUA,NTTP,NTTD,IRET
  15.  
  16. C =========================================
  17. IRET=0
  18.  
  19. SEGACT M1
  20.  
  21. C Si les matrices ne sont pas morse, on les crees
  22. C en morse
  23. IF (M1.IRIGEL(7,1).NE.6) THEN
  24. CALL ELMORS(M1,1)
  25. END IF
  26.  
  27. SEGACT M2
  28.  
  29. IF (M2.IRIGEL(7,1).NE.6) THEN
  30. CALL ELMORS(M2,1)
  31. END IF
  32.  
  33. SEGACT M1,M2
  34.  
  35. PMS1=M1.IRIGEL(5,1)
  36. PMS2=M2.IRIGEL(5,1)
  37.  
  38. IZA1=M1.IRIGEL(6,1)
  39. IZA2=M2.IRIGEL(6,1)
  40.  
  41. IMAT1=M1.IRIGEL(4,1)
  42. IMAT2=M2.IRIGEL(4,1)
  43.  
  44. SEGACT IMAT1,IMAT2
  45.  
  46. NBSOUS=IMAT1.LIZAFM(/1)
  47. NBME1=IMAT1.LIZAFM(/2)
  48. NBME2=IMAT2.LIZAFM(/2)
  49.  
  50. IF (NBME1.NE.NBME2) THEN
  51. WRITE(6,*) 'ADDMAT: Les 2 MATRIK n ont pas'
  52. WRITE(6,*) 'le meme support, impossible de les'
  53. WRITE(6,*) 'additionner.'
  54. IRET=1
  55. RETURN
  56. ELSE
  57. IFLAG=0
  58. NBME=NBME1
  59. DO I=1,NBME
  60. IF ((IMAT1.LISPRI(I).NE.IMAT2.LISPRI(I)).OR.
  61. & (IMAT1.LISDUA(I).NE.IMAT2.LISDUA(I))) THEN
  62. IFLAG=1
  63. END IF
  64. END DO
  65. IF (IFLAG.NE.0) THEN
  66. WRITE(6,*) 'ADDMAT: Les 2 MATRIK n ont pas'
  67. WRITE(6,*) 'le meme support, impossible de les'
  68. WRITE(6,*) 'additionner.'
  69. IRET=1
  70. RETURN
  71. END IF
  72. END IF
  73.  
  74. SEGINI IMAT3
  75.  
  76. C On recopie le segact IMATRI de la matrice 1 dans le IMATRI
  77. C pour la matrice 3
  78.  
  79. DO I=1,NBME
  80. IMAT3.LISPRI(I)=IMAT1.LISPRI(I)
  81. IMAT3.LISDUA(I)=IMAT1.LISDUA(I)
  82. END DO
  83. IMAT3.KSPGP=IMAT1.KSPGP
  84. IMAT3.KSPGD=IMAT1.KSPGD
  85.  
  86. C On initialise M3
  87. NMATRI=1
  88. NRIGE=7
  89. NKID=9
  90. NKMT=7
  91. SEGINI M3
  92.  
  93. M3.KMINCP=M1.KMINCP
  94. M3.KMINCD=M1.KMINCD
  95. c WRITE(6,*) 'ADDMAT',M1.KMINCP,M1.KMINCD
  96.  
  97. CALL RSETI(M3.IRIGEL(1,1),M1.IRIGEL(1,1),7)
  98.  
  99. SEGACT PMS1,PMS2
  100. SEGACT IZA1,IZA2
  101.  
  102. NTT=PMS1.IA(/1)-1
  103.  
  104. NBCOMP=10
  105. NTA=NTT
  106. SEGINI ASSTAB
  107.  
  108. DO I=1,NTT
  109. LI1=PMS1.IA(I)
  110. NB1=PMS1.IA(I+1)-PMS1.IA(I)
  111.  
  112. LI2=PMS2.IA(I)
  113. NB2=PMS2.IA(I+1)-PMS2.IA(I)
  114.  
  115. DO J=1,NB1
  116. NB=ITAB(1,I)
  117. PRI=PMS1.JA(LI1+J-1)
  118.  
  119. 10 IF (NB+1.GE.NBCOMP) THEN
  120. NBCOMP=NBCOMP+10
  121. SEGADJ ASSTAB
  122. GO TO 10
  123. END IF
  124.  
  125. C On regarde sur la ligne DUA si la colonne PRI est
  126. C deja inserer dans le profil ITAB
  127. DO II=1,NB
  128. IF (ITAB(II+1,I).EQ.PRI) GO TO 30
  129. END DO
  130. ITAB(1,I)=NB+1
  131. ITAB(NB+2,I)=PRI
  132.  
  133. 30 CONTINUE
  134. END DO
  135.  
  136. DO J=1,NB2
  137. NB=ITAB(1,I)
  138. PRI=PMS2.JA(LI2+J-1)
  139.  
  140. 35 IF (NB+1.GE.NBCOMP) THEN
  141. NBCOMP=NBCOMP+10
  142. SEGADJ ASSTAB
  143. GO TO 35
  144. END IF
  145.  
  146. C On regarde sur la ligne DUA si la colonne PRI est
  147. C deja inserer dans le profil ITAB
  148. DO II=1,NB
  149. IF (ITAB(II+1,I).EQ.PRI) GO TO 40
  150. END DO
  151. ITAB(1,I)=NB+1
  152. ITAB(NB+2,I)=PRI
  153.  
  154. 40 CONTINUE
  155. END DO
  156. END DO
  157.  
  158. DO I=1,NTT
  159. CALL ORDOTA(ITAB(2,I),ITAB(1,I))
  160. END DO
  161.  
  162. c write(6,*)' KTAB ************** NPTD=',NTT
  163. c DO II=1,NTT
  164. c nb=ITAB(1,II)
  165. c write(6,*)' II=',ii,' NB=',nb
  166. c write(6,*)(ITAB(ji+1,ii),ji=1,nb)
  167. c END DO
  168.  
  169. c SEGDES ASSTAB
  170. M3.KNTTD=NTT
  171. c CALL PFMORS(ASSTAB,M3,1)
  172.  
  173. NJA=PMS1.JA(/1)
  174. SEGINI PMS3
  175.  
  176. M=0
  177. DO I=1,NTT
  178. NB=ITAB(1,I)
  179.  
  180. PMS3.IA(I)=M+1
  181. DO J=1,NB
  182. M=M+1
  183. 110 CONTINUE
  184. IF (M.GT.NJA) THEN
  185. NJA=NJA+100
  186. SEGADJ PMS3
  187. GOTO 110
  188. END IF
  189.  
  190. PMS3.JA(M)=ITAB(J+1,I)
  191. END DO
  192. END DO
  193.  
  194. PMS3.IA(NTT+1)=M+1
  195. NJA=M
  196. SEGADJ PMS3
  197.  
  198. c SEGACT M3*MOD
  199. c PMS3=M3.IRIGEL(5,1)
  200. c SEGACT PMS3
  201. NBVA=PMS3.JA(/1)
  202. SEGINI IZA3
  203.  
  204. N=PMS3.IA(/1)
  205. c WRITE(6,*) 'N=',N
  206. c DO I=1,N
  207. c WRITE(6,*) I,'IA',PMS3.IA(I)
  208. c END DO
  209. c WRITE(6,*) 'NBVA=',NBVA
  210. c DO I=1,NBVA
  211. c WRITE(6,*) I,'JA',PMS3.JA(I)
  212. c END DO
  213.  
  214. NTT=PMS3.IA(/1)-1
  215. DO I=1,NTT
  216.  
  217. LI1=PMS1.IA(I)
  218. NB1=PMS1.IA(I+1)-PMS1.IA(I)
  219.  
  220. LI2=PMS2.IA(I)
  221. NB2=PMS2.IA(I+1)-PMS2.IA(I)
  222.  
  223. DO J=1,NB1
  224. PRI=PMS1.JA(LI1+J-1)
  225.  
  226. MA=IMORSE(PMS1.IA,PMS1.JA,I,PRI)
  227. MM=IMORSE(PMS3.IA,PMS3.JA,I,PRI)
  228.  
  229. IZA3.A(MM)=IZA3.A(MM)+IZA1.A(MA)
  230. END DO
  231.  
  232. DO J=1,NB2
  233. PRI=PMS2.JA(LI2+J-1)
  234.  
  235. MA=IMORSE(PMS2.IA,PMS2.JA,I,PRI)
  236. MM=IMORSE(PMS3.IA,PMS3.JA,I,PRI)
  237.  
  238. IZA3.A(MM)=IZA3.A(MM)+IZA2.A(MA)
  239. END DO
  240. END DO
  241.  
  242. SEGDES PMS1,PMS2,PMS3
  243. SEGDES IZA1,IZA2,PMS3
  244. C SEGSUP ASSTAB
  245.  
  246. C On remplit les pointeurs de M3
  247.  
  248. M3.IRIGEL(4,1)=IMAT3
  249. M3.IRIGEL(5,1)=PMS3
  250. M3.IRIGEL(6,1)=IZA3
  251. M3.IRIGEL(7,1)=6
  252.  
  253. M3.KSYM=2
  254. M3.KNTTP=M2.KNTTP
  255. M3.KNTTD=M1.KNTTD
  256.  
  257. SEGDES IMAT1,IMAT2,IMAT3
  258. SEGDES M1,M2,M3
  259.  
  260. CALL OPTIM(M3,1)
  261. RETURN
  262. END
  263.  
  264.  
  265.  
  266.  
  267.  
  268.  

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