1 : C LDMT SOURCE CHAT 09/10/09 21:20:12 6519 2 : SUBROUTINE LDMT(KRIGI,IDAMEM,NOID,NOEN,PREC) 3 : C 4 : C **** SUBROUTINE QUI EXECUTE L OPERATION RESOU 5 : C SUR DES MATRICES SANS SYMETRIES 6 : C **** APPELEE PAR RESOU OU PAR SUPRI 7 : C 8 : C Elle est équivalente à RESOU1 dans le cas de l'inversion des 9 : C matrices symétriques 10 : C 11 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 12 : C 13 : C Auteur : Michel BULIK 14 : C 15 : C Date : Printemps '95 16 : C 17 : C Langage : ESOPE + FORTRAN77 18 : C 19 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 20 : IMPLICIT INTEGER(I-N) 21 : REAL*8 XKT,PREC 22 : INTEGER OOOVAL 23 : SEGMENT IDEMEM(0) 24 : -INC SMRIGID 25 : -INC SMVECTD 26 : -INC CCOPTIO 27 : -INC SMMATRI 28 : C 29 : MRIGID=KRIGI 30 : SEGACT MRIGID 31 : ICHOLX=ICHOLE 32 : SEGDES MRIGID 33 : IF(ICHOLX.NE.0) then 34 : MMATRI=ICHOLX 35 : SEGACT MMATRI 36 : IF (PRCHLV.lt.PREC*1.001.and.PRCHLV.gt.PREC*0.999) GO TO 1 37 : write (6,*) ' attention changement de precision ' 38 : MILIGN=IILIGN 39 : segact milign 40 : DO 20 I=1,ILIGN(/1) 41 : LIGN=ILIGN(I) 42 : SEGSUP LIGN 43 : SEGSUP LIGN 44 : 20 CONTINUE 45 : MDIAG=IDIAG 46 : SEGSUP MDIAG 47 : MDNOR=IDNORM 48 : SEGSUP MDNOR 49 : SEGSUP MMATRI 50 : ICHOLX=0 51 : ENDIF 51 : CALL LDMT1(KRIGI,PREC) 52 : IF(IERR.NE.0) GO TO 5000 53 : MRIGID=KRIGI 54 : SEGACT MRIGID 55 : ICHOLX=ICHOLE 56 : SEGDES MRIGID 57 : C 58 : C **** SUBROUTINE CHV2 : TRANSFORME LE CHPOIN ISECO EN VECTEUR 59 : C 60 : 1 CONTINUE 61 : IDEMEM=IDAMEM 62 : SEGACT IDEMEM*MOD 63 : NNTOT=IDEMEM(/1) 64 : MMATRI=ICHOLX 65 : SEGACT MMATRI 66 : MILIGN=IILIGN 67 : SEGACT,MILIGN 68 : INK=IPNO(/1) 69 : SEGDES MILIGN,MMATRI 69 : CALL INTPDO(LENB) 70 : NNPA= MAX(1,((OOOVAL(1,1)-NGMAXY)/(2*LENB))/INK+1) 71 : C 72 : C ON TRAVAILLE AVEC AUTANT DE VECTEUR SIMULTANEE QU'IL EN RENTRE DANS 73 : C LA MOITIE DE LA MEMOIRE CENTRALE 74 : C 75 : NN=NNPA 76 : DO 201 KGEN = 1,NNTOT,NNPA 77 : IF(KGEN+NNPA-1.GT.NNTOT) NN= NNTOT-KGEN+1 78 : KGEN1=KGEN-1 79 : DO 2 K=1,NN 80 : ISECO=IDEMEM(K+KGEN1) 80 : CALL CHVNS(ICHOLX,ISECO,MVECTX,NOID) 81 : IF(IERR.NE.0) GO TO 5000 82 : IDEMEM(K+KGEN1)=MVECTX 83 : 2 CONTINUE 84 : IF(NN.NE.1) THEN 85 : INC = INK * NN 86 : SEGINI MVECTD 87 : DO 3 LL=1,NN 88 : LD=INK*(LL-1) 89 : MVECT1=IDEMEM(LL+KGEN1) 90 : SEGACT MVECT1 91 : DO 4 L=1,INK 92 : 4 VECTBB(L+LD)=MVECT1.VECTBB(L) 93 : SEGSUP MVECT1 94 : 3 CONTINUE 95 : MVECTX=MVECTD 96 : SEGDES MVECTD 97 : ENDIF 98 : C 99 : C **** SUBROUTINE MONDES : 100 : C 101 : IF(IIMPI.EQ.1) THEN 102 : WRITE(IOIMP,499) 103 : 499 FORMAT(' TEMPS SUIVANT AVANT APPEL MONDES') 103 : CALL GIBTEM(XKT) 104 : INTERR(1)=XKT 104 : CALL ERREUR(-259) 105 : ENDIF 105 : CALL MONDES(ICHOLX,MVECTX,NOEN) 106 : IF(IIMPI.EQ.1) THEN 107 : WRITE(IOIMP,498) 108 : 498 FORMAT(' TEMPS SUIVANT APRES APPEL MONDES') 108 : CALL GIBTEM(XKT) 109 : INTERR(1)=XKT 109 : CALL ERREUR(-259) 110 : ENDIF 111 : IF(IERR.NE.0) GO TO 5000 112 : C 113 : C **** SUBROUTINE VCH1 : REMET LE VECTEUR SOUS FORME D UN CHPOINT 114 : C **** LE CHPOINT EST DE TYPE PREMIER MEMBRE 115 : C 116 : MVECTA=MVECTX 117 : DO 5 K=1,NN 118 : IF(NN.EQ.1) GO TO 10 119 : IF(K.EQ.1) THEN 120 : INC=INK 121 : MVECT1=MVECTX 122 : SEGACT MVECT1 123 : SEGINI MVECTD 124 : ENDIF 125 : SEGACT MVECTD*mod 126 : LD=(K-1)*INK 127 : DO 6 L=1,INK 128 : VECTBB(L)=MVECT1.VECTBB(L+LD) 129 : 6 CONTINUE 130 : MVECTA=MVECTD 131 : SEGDES MVECTD 132 : IF(K.EQ.NN) SEGSUP MVECT1 133 : 10 CONTINUE 133 : CALL VCH1(ICHOLX,MVECTA,ISOLU,KRIGI) 134 : IF(IERR.NE.0) RETURN 135 : C 136 : IDEMEM(K+KGEN1)=ISOLU 137 : 5 CONTINUE 138 : MVECTD=MVECTA 139 : SEGSUP MVECTD 140 : 201 CONTINUE 141 : IDAMEM = IDEMEM 142 : SEGDES IDEMEM 143 : C 144 : 5000 CONTINUE 145 : RETURN 146 : END 147 : 148 : 149 : 150 : 151 : 152 : 153 : 154 : 155 : 156 : 157 : 158 : 159 : 160 : 161 : 162 : 163 :
© Cast3M 2003 - All rights reserved.
Disclaimer