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