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