1 : C KMFN SOURCE MAGN 09/07/30 21:17:32 6458 2 : SUBROUTINE KMFN 3 : C *********************************************************************** 4 : C 5 : C Objet : Cet operateur calcule soit A * U 6 : C t 7 : C soit A U 8 : C Syntaxe : 9 : C CAS 1 / 10 : C 11 : C B = KMF MATRIK MCHPOI ; 12 : C 13 : C 14 : C CAS 2 / 15 : C 16 : C B = KMF MATRIK MCHPOI 'TRAN' ; 17 : C 18 : C MATRIK MATRICES ELEMENTAIRES 19 : C MCHPOI CHPOINT CONTENANT U 20 : C 21 : C *********************************************************************** 22 : IMPLICIT INTEGER(I-N) 23 : IMPLICIT REAL*8 (A-H,O-Z) 24 : -INC CCOPTIO 25 : -INC SMELEME 26 : POINTEUR MELEMP.MELEME,MELEMD.MELEME,MELEM1.MELEME 27 : POINTEUR ISPGD.MELEME 28 : -INC SMLENTI 29 : -INC SMMATRIK 30 : -INC SMCHPOI 31 : POINTEUR MCHINI.MCHPOI 32 : LOGICAL LNEW,LFIRST 33 : CHARACTER*8 NOMP,NOMD,NOMD0,LDLP,NOMDX 34 : CHARACTER*4 LISMOT(1) 35 : DATA LISMOT/'TRAN'/ 36 : C**** 37 : MPOVA1=0 38 : C write(6,*)' SUBROUTINE KMFN' 39 : C LECTURE DES ARGUMENTS 39 : CALL LIROBJ('MATRIK',MATRIK,1,IRET) 40 : IF(IRET.EQ.0) RETURN 40 : CALL LIROBJ('CHPOINT',MCHPOI,1,IRET) 41 : IF(IRET.EQ.0) RETURN 41 : CALL LIRMOT(LISMOT,1,ITRAN,0) 42 : ITRAN0=ITRAN 43 : SEGACT MATRIK 44 : SEGACT MCHPOI 45 : SEGINI,MCHINI=MCHPOI 46 : NSOUPO=0 47 : NAT=MCHINI.JATTRI(/1) 48 : SEGADJ MCHINI 49 : SEGDES MCHINI 49 : CALL ECROBJ('CHPOINT',MCHINI) 50 : NOMD0=' ' 51 : MLENT2=0 52 : ISPGD0=0 53 : MCHPO1=0 54 : IT=0 55 : NMATRI=IRIGEL(/2) 56 : NSP2 =IPCHP(/1) 57 : LFIRST=.TRUE. 58 : DO 5000 IM=1,NMATRI 59 : IKT=1 60 : IMATRI=IRIGEL(4,IM) 61 : SEGACT IMATRI 62 : NBME =LIZAFM(/2) 63 : ITYM=IRIGEL(7,IM) 64 : IF(ITYM.EQ.4)ITRAN=0 65 : 777 CONTINUE 66 : DO 5001 LP=NBME,1,-1 67 : IF(ITRAN.EQ.0)THEN 68 : NOMP=LISPRI(LP) 69 : ELSE 70 : NOMP=LISDUA(LP) 71 : ENDIF 72 : C write(6,*)' LP,NBME,ITRAN,LISPRI(LP),LISDUA(LP)=', 73 : C &LP,NBME,ITRAN,LISPRI(LP),LISDUA(LP) 74 : DO 4000 KS=1,NSP2 75 : MSOUPO=IPCHP(KS) 76 : SEGACT MSOUPO 77 : NC=NOCOMP(/2) 78 : DO 4001 KC=1,NC 79 : C WRITE(IOIMP,*)'KMFN : NOCOMP=',NOCOMP(KC),' NOMP=',NOMP(1:4) 80 : IF (NOCOMP(KC).EQ.NOMP(1:4)) THEN 81 : IT=1 82 : MELEM1=IGEOC 83 : C In KRIPAD : SEGACT MELEM1 84 : C In KRIPAD : SEGINI MLENTI 84 : CALL KRIPAD(MELEM1,MLENTI) 85 : C segact melem1 86 : C nk1=melem1.num(/1) 87 : C nk2=melem1.num(/2) 88 : C write(6,*)'Controle MELEM1=IGEOC',MELEM1,NK1,NK2 89 : C write(6,1101)(melem1.num(1,kk),kk=1,nk2) 90 : 91 : SEGDES MELEM1 92 : MPOVAL=IPOVAL 93 : SEGACT MPOVAL 94 : IF (ITRAN.EQ.0) THEN 95 : MELEMP=IRIGEL(1,IM) 96 : MELEMD=IRIGEL(2,IM) 97 : IKSPGD=KSPGD 98 : LDLP=LISDUA(LP) 99 : ELSE 100 : MELEMP=IRIGEL(2,IM) 101 : MELEMD=IRIGEL(1,IM) 102 : IKSPGD=KSPGP 103 : LDLP=LISPRI(LP) 104 : ENDIF 105 : ISPGD=ISPGD0 106 : NOMD=NOMD0 107 : LNEW=((ISPGD0.NE.IKSPGD).OR.(NOMD0.NE.LDLP)) 108 : IF (LNEW) THEN 109 : IF (.NOT.LFIRST) THEN 110 : SEGSUP MLENT2 111 : SEGDES MPOVA1 112 : SEGDES MSOUP1 113 : SEGDES MCHPO1 114 : ELSE 115 : LFIRST=.FALSE. 116 : ENDIF 117 : IF (ITRAN.EQ.0) THEN 118 : NOMD=LISDUA(LP) 119 : NOMD0=LISDUA(LP) 120 : ISPGD=KSPGD 121 : ISPGD0=KSPGD 122 : ELSE 123 : NOMD=LISPRI(LP) 124 : NOMD0=LISPRI(LP) 125 : ISPGD=KSPGP 126 : ISPGD0=KSPGP 127 : ENDIF 128 : SEGACT ISPGD 129 : N=ISPGD.NUM(/2) 130 : NC=1 131 : C WRITE(IOIMP,*)' Creation MPOVA1 N,NC=',n,nc 132 : IF (MCHPO1.NE.0)THEN 132 : CALL ECROBJ('CHPOINT',MCHPO1) 132 : CALL PRFUSE 132 : CALL DTCHPO(MCHPO1) 133 : ENDIF 134 : SEGINI,MCHPO1=MCHPOI 135 : NSOUPO=1 136 : NAT=MCHPO1.JATTRI(/1) 137 : SEGADJ MCHPO1 138 : C WRITE(IOIMP,*)' On cree MPOVA1 -> ',NOMD(1:4) 139 : SEGINI MSOUP1 140 : SEGINI MPOVA1 141 : MCHPO1.IPCHP(NSOUPO)=MSOUP1 142 : MSOUP1.NOCOMP(1)=NOMD(1:4) 143 : MSOUP1.IGEOC=ISPGD 144 : MSOUP1.IPOVAL=MPOVA1 145 : C In KRIPAD : SEGINI MLENT2 145 : CALL KRIPAD(ISPGD,MLENT2) 146 : C segact ISPGD 147 : C nk1=ISPGD.num(/1) 148 : C nk2=ISPGD.num(/2) 149 : C write(6,*)'Controle ISPGD',ISPGD,NK1,NK2 150 : C write(6,1101)(ISPGD.num(1,kk),kk=1,nk2) 151 : 152 : SEGDES ISPGD 153 : ENDIF 154 : C WRITE(IOIMP,*)' On charge dans ',MSOUP1.NOCOMP(1) 155 : 156 : 156 : C CALL VERPAD(MLENTI,MELEMP,IRET) 157 : C IRET=0 158 : C IF(IRET.NE.0)THEN 159 : C write(6,*)' VERPAD Pb MELEMP ' 160 : C write(6,*)' MELEMP=',MELEMP,'ITRAN=',ITRAN 161 : C segact melemp 162 : C nk1= melemp.num(/1) 163 : C nk2= melemp.num(/2) 164 : C do 6317 kkk=1,nk2 165 : C write(6,1101)(melemp.num(kk,kkk),kk=1,nk1) 166 : C6317 continue 167 : C 168 : C 169 : C MOTERR(1:40)=' ' 170 : C MOTERR(1:8) ='MATRIK ' 171 : C MOTERR(9:16)='CHPOINT ' 172 : C Incompatibilité entre l'objet %m1:8 et l'objet %m9:16 172 : C CALL ERREUR(135) 173 : C RETURN 174 : C ENDIF 175 : 175 : CALL VERPAD(MLENT2,MELEMD,IRET) 176 : C IRET=0 177 : IF(IRET.NE.0)THEN 178 : C write(6,*)' VERPAD Pb MELEMD ' 179 : C write(6,*)' MELEMD=',MELEMD,'ITRAN=',ITRAN 180 : C segact melemd 181 : C nk1= melemd.num(/1) 182 : C nk2= melemd.num(/2) 183 : C do 6318 kkk=1,nk2 184 : C write(6,1101)(melemd.num(kk,kkk),kk=1,nk1) 185 : C6318 continue 186 : 187 : MOTERR(1:40)=' ' 188 : MOTERR(1:8) ='MATRIK ' 189 : MOTERR(9:16)='CHPOINT ' 190 : C Incompatibilité entre l'objet %m1:8 et l'objet %m9:16 190 : CALL ERREUR(135) 191 : RETURN 192 : ENDIF 193 : SEGACT MELEMP 194 : SEGACT MELEMD 195 : NBSOUM=LIZAFM(/1) 196 : 197 : NBSP=MELEMP.LISOUS(/1) 198 : NBSD=MELEMD.LISOUS(/1) 199 : IPT1=MELEMP 200 : IPT2=MELEMD 201 : IF(NBSP.NE.0)IPT1=MELEMP.LISOUS(1) 202 : IF(NBSD.NE.0)IPT2=MELEMD.LISOUS(1) 203 : SEGACT IPT1,IPT2 204 : NBELP=IPT1.NUM(/2) 205 : NBELD=IPT2.NUM(/2) 206 : KKP=0 207 : KKD=0 208 : NSP=1 209 : NSD=1 210 : 211 : DO 4002 LS=1,NBSOUM 212 : IZAFM=LIZAFM(LS,LP) 213 : SEGACT IZAFM 214 : NBEL=AM(/1) 215 : NP=AM(/2) 216 : MP=AM(/3) 217 : C WRITE(IOIMP,*)' BCL 4002 LS=',ls,nbel,np,mp 218 : IF(ITRAN.EQ.0)THEN 219 : DO 4033 K=1,NBEL 220 : KKP=KKP+1 221 : KKD=KKD+1 222 : 223 : DO 4034 J=1,MP 224 : U=0.D0 225 : DO 4035 I=1,NP 226 : I1=LECT(IPT1 .NUM(I,KKP)) 227 : IF(I1.EQ.0)GO TO 4035 228 : U=U+AM(K,I,J)*VPOCHA(I1,KC) 229 : 4035 CONTINUE 230 : III=IPT2 .NUM(J,KKD) 231 : I2=MLENT2.LECT(III) 232 : MPOVA1.VPOCHA(I2,1)=MPOVA1.VPOCHA(I2,1) 233 : $ +U 234 : 4034 CONTINUE 235 : 4033 CONTINUE 236 : 237 : IF(KKP.EQ.NBELP.AND.NSP.LT.NBSP)THEN 238 : NSP=NSP+1 239 : SEGDES IPT1 240 : IPT1=MELEMP.LISOUS(NSP) 241 : SEGACT IPT1 242 : NBELP=IPT1.NUM(/2) 243 : KKP=0 244 : ENDIF 245 : 246 : IF(KKD.EQ.NBELD.AND.NSD.LT.NBSD)THEN 247 : NSD=NSD+1 248 : SEGDES IPT2 249 : IPT2=MELEMD.LISOUS(NSD) 250 : SEGACT IPT2 251 : NBELD=IPT2.NUM(/2) 252 : KKD=0 253 : ENDIF 254 : 255 : ELSE 256 : DO 3033 K=1,NBEL 257 : KKP=KKP+1 258 : KKD=KKD+1 259 : 260 : DO 3034 J=1,NP 261 : U=0.D0 262 : DO 3035 I=1,MP 263 : I1=LECT(IPT1 .NUM(I,KKP)) 264 : IF(I1.EQ.0)GO TO 3035 265 : U=U+AM(K,J,I)*VPOCHA(I1,KC) 266 : 3035 CONTINUE 267 : I2=MLENT2.LECT(IPT2 .NUM(J,KKD)) 268 : MPOVA1.VPOCHA(I2,1)=MPOVA1.VPOCHA(I2,1) 269 : $ +U 270 : 3034 CONTINUE 271 : 3033 CONTINUE 272 : 273 : IF(KKP.EQ.NBELP.AND.NSP.LT.NBSP)THEN 274 : NSP=NSP+1 275 : SEGDES IPT1 276 : IPT1=MELEMP.LISOUS(NSP) 277 : SEGACT IPT1 278 : NBELP=IPT1.NUM(/2) 279 : KKP=0 280 : ENDIF 281 : 282 : IF(KKD.EQ.NBELD.AND.NSD.LT.NBSD)THEN 283 : NSD=NSD+1 284 : SEGDES IPT2 285 : IPT2=MELEMD.LISOUS(NSD) 286 : SEGACT IPT2 287 : NBELD=IPT2.NUM(/2) 288 : KKD=0 289 : ENDIF 290 : 291 : ENDIF 292 : SEGDES IZAFM 293 : 4002 CONTINUE 294 : SEGDES MELEMP 295 : SEGDES MELEMD 296 : SEGDES MPOVAL 297 : SEGSUP MLENTI 298 : ENDIF 299 : 4001 CONTINUE 300 : SEGDES MSOUPO 301 : 4000 CONTINUE 302 : 5001 CONTINUE 303 : C write(6,*)' ITYM,IKT,ITRAN=',ITYM,IKT,ITRAN 304 : IF(ITYM.EQ.4)THEN 305 : IF(IKT.EQ.1)THEN 306 : IKT=2 307 : ITRAN=1 308 : GO TO 777 309 : ELSE 310 : ITRAN=ITRAN0 311 : IKT=1 312 : ENDIF 313 : ENDIF 314 : SEGDES IMATRI 315 : 5000 CONTINUE 316 : SEGSUP MLENT2 317 : C write(6,*)' MPOVA1=',MPOVA1 318 : C write(6,*)' FIN SUBROUTINE KMFN' 319 : IF(MPOVA1.EQ.0)THEN 320 : MOTERR(1:40)=' ' 321 : MOTERR(1:8) ='MATRIK ' 322 : MOTERR(9:16)='CHPOINT ' 323 : C Incompatibilité entre l'objet %m1:8 et l'objet %m9:16 323 : CALL ERREUR(135) 324 : RETURN 325 : ENDIF 326 : c SEGDES MPOVA1 327 : SEGDES MSOUP1 328 : SEGDES MCHPO1 328 : C CALL DTCHPO(MCHINI) 329 : SEGDES MCHPOI 330 : SEGDES MATRIK 331 : IF(IT.EQ.1)THEN 331 : CALL ECROBJ('CHPOINT',MCHPO1) 331 : CALL PRFUSE 331 : CALL DTCHPO(MCHPO1) 332 : ELSE 333 : MOTERR(1:40)=' ' 334 : MOTERR(1:8) ='MATRIK ' 335 : MOTERR(9:16)='CHPOINT ' 336 : C Incompatibilité entre l'objet %m1:8 et l'objet %m9:16 336 : CALL ERREUR(135) 337 : ENDIF 338 : RETURN 339 : 1101 FORMAT(20(1X,I5)) 340 : END 341 : 342 : 343 : 344 : 345 : 346 : 347 : 348 : 349 : 350 :
© Cast3M 2003 - All rights reserved.
Disclaimer