1 : C CONREL SOURCE CHAT 05/01/12 22:18:30 5004 2 : C SUBROUTINE CONREL (MATRED, ILDIM, CONVRG,I ) 3 : ************************************************************************ 4 : * 5 : * CONREL 6 : * ----------- 7 : * 8 : * FONCTION: 9 : * --------- 10 : * 11 : * REALISE LE CRITERE DE CONVERGENCE DE L'ITERATION DANS LE CAS DE 12 : * VALEURS PROPRES REELLES. 13 : * 14 : * MODE D'APPEL: 15 : * ------------- 16 : * 16 : * CALL CONREL (MATRED, ILDIM , CONVRG) 17 : * 18 : * PARAMETRES: (E)=ENTREE (S)=SORTIE 19 : * ----------- 20 : * 21 : * MATRED TABLEAU (E) TABLEAU CONTENANT LES COORDONNEES 22 : * DU SYSTEME REDUIT, ET CELLES DES 23 : * VECTEURS DE DEUX ITERATIONS SUCCESSIVES. 24 : * 25 : * 26 : * AUTEUR, DATE DE CREATION: 27 : * ------------------------- 28 : * 29 : * C. LE BIDEAU 09 / 2001 ( FORTRAN + ESOPE ) 30 : * 31 : *********************************************************************** 32 : 33 : SUBROUTINE CONREL (MATRED, ILDIM, CONVRG,I ) 34 : 35 : IMPLICIT INTEGER(I-N) 36 : IMPLICIT REAL*8 (A-H,O-Z) 37 : 38 : -INC CCOPTIO 39 : -INC SMLCHPO 40 : -INC SMLREEL 41 : 42 : ****** 43 : * -- ARGUMENTS -- 44 : *** 45 : INTEGER ILDIM, CONVRG 46 : SEGMENT MATRED 47 : REAL*8 MATVEC (N, N),MATVE1(N,N), XMAT(N, N) 48 : END SEGMENT 49 : SEGMENT INTER 50 : REAL*8 RES(N4,N4) 51 : END SEGMENT 52 : ****** 53 : * INITIALISATION 54 : *** 55 : CONVRG = 0 56 : N4 =ILDIM 57 : SEGINI INTER 58 : ****** 59 : * DIFFERENCE DES VECTEURS 60 : * ET NORME DE LA DIFFERENCE 61 : *** 62 : DO 100 IB100 = 1, ILDIM 63 : XN1=0.D0 64 : XN2=0.D0 65 : XS =0.D0 66 : XD =0.D0 67 : DO 200 IB200 = 1, ILDIM 68 : XS=MATVEC(IB200,IB100)+MATVE1(IB200,IB100) 69 : XD=MATVEC(IB200,IB100)-MATVE1(IB200,IB100) 70 : XN1=XN1+(XD)**2 71 : XN2=XN2+(XS)**2 72 : 200 CONTINUE 73 : IF (XN1 .GT. 1.D-15.AND. 74 : & XN2 .GT. 1.D-15) THEN 75 : ****** 76 : * test dimension vecteur ib100: si complexe dimension 2 77 : *** 78 : DO 300 IB300 = 1, ILDIM 79 : XX=0.D0 80 : XP=0.D0 81 : DO 350 IB350= 1, ILDIM 82 : XP=XMAT(IB300, IB350)*MATVEC(IB350, IB100) 83 : XX = XX+ XP 84 : 350 CONTINUE 85 : RES(ib300,ib100)=XX 86 : 300 CONTINUE 87 : ****** 88 : * DECOMPOSITION SUR LES DEUX ITERES PRECEDENTS 89 : *** 90 : XN=0.D0 91 : DO 1000 IB1000 = 1, ILDIM 92 : XN = XN + MATVE1(IB1000, IB100)**2 93 : 1000 CONTINUE 94 : DO 1500 IB1500 = 1, ILDIM 95 : MATVE1(IB1500,IB100)= MATVE1(IB1500,IB100)/SQRT(XN) 96 : 1500 CONTINUE 97 : XP = 0.D0 98 : DO 400 IB400=1, ILDIM 99 : XP=XP+MATVEC(IB400,IB100)* 100 : & MATVE1(IB400,IB100) 101 : 400 CONTINUE 102 : DO 5000 IB5000=1,ILDIM 103 : MATVEC(IB5000,IB100)=MATVEC(IB5000,IB100) 104 : & -XP*MATVE1(IB5000,IB100) 105 : XN=XN+MATVEC(IB5000,IB100)**2 106 : 5000 CONTINUE 107 : DO 600 IB600=1, ILDIM 108 : MATVEC(IB600,IB100)=MATVEC(IB600,IB100) 109 : & /SQRT(XN) 110 : 600 CONTINUE 111 : XP1=0.D0 112 : XP2=0.D0 113 : DO 4000 IB4000=1, ILDIM 114 : XP1=XP1+RES(IB4000,IB100)* 115 : & MATVE1(IB4000,IB100) 116 : XP2=XP2+RES(IB4000,IB100)* 117 : & MATVEC(IB4000,IB100) 118 : 4000 CONTINUE 119 : XN=0.D0 120 : DO 6000 IB6000=1,ILDIM 121 : RES(IB6000,IB100)=RES(IB6000,IB100) 122 : & -XP1*MATVE1(IB6000,IB100) 123 : & -XP2*MATVEC(IB6000,IB100) 124 : XN=XN+RES(IB6000,IB100)**2 125 : 6000 CONTINUE 126 : * WRITE(6,*)'CRITERE CONV', XN 127 : IF(XN.GT.1E-10) CONVRG = CONVRG + 1 128 : END IF 129 : 130 : 100 CONTINUE 131 : 132 : 133 : SEGSUP INTER 134 : END 135 : 136 :
© Cast3M 2003 - All rights reserved.
Disclaimer