1 : C SOMME1 SOURCE CHAT 05/01/13 03:22:02 5004 2 : SUBROUTINE SOMME1 (KFONCT,X0,X8,DX, KSOMME) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8 (A-H,O-Z) 5 : ************************************************************************ 6 : * 7 : * S O M M E 1 8 : * ----------- 9 : * 10 : * FONCTION: 11 : * --------- 12 : * 13 : * CREATION, A PARTIR DE FONCTIONS "F", LES FONCTIONS "G" TELLES: 14 : * 15 : * X 16 : * / 17 : * G(X) = / F(T).DT 18 : * / 19 : * X-DX 20 : * 21 : * CES FONCTIONS ETANT TOUTES DEFINIES PAR DES SUITES DE COUPLES DE 22 : * VALEURS (X,F(X)), ORDONNES STRICTEMENT SELON LES "X" CROISSANTS. 23 : * 24 : * MODULES UTILISES: 25 : * ----------------- 26 : * 27 : -INC SMEVOLL 28 : -INC SMLREEL 29 : * 30 : * PARAMETRES: (E)=ENTREE (S)=SORTIE (+ = CONTENU DANS UN COMMUN) 31 : * ----------- 32 : * 33 : * KFONCT (E) OBJET "EVOLUTION" REPRESENTANT LES FONCTIONS A 34 : * INTEGRER. 35 : * X0, X8 (E) INTERVALLE TOTAL SUR LEQUEL LES FONCTIONS SERONT 36 : * INTEGREES. 37 : * DX (E) LONGUEUR DES INTERVALLES D'INTEGRATION. 38 : * LES FONCTIONS INTEGRALES PRENDRONT DONC LEUR 1ERE 39 : * VALEUR EN X0+DX ET LEUR DERNIERE VALEUR AUTOUR DE 40 : * X8 (SELON DX). 41 : * KSOMME (S) OBJET "EVOLUTION" REPRESENTANT LES FONCTIONS 42 : * INTEGRALES. 43 : * 44 : REAL*8 X0,X8,DX 45 : * 46 : * VARIABLES: 47 : * ---------- 48 : * 49 : * 5 = INDICE SIGNIFIANT "BORNE INFERIEURE" POUR UN INTERVALLE 50 : * D'INTEGRATION DONNE. 51 : * 6 = INDICE SIGNIFIANT "BORNE SUPERIEURE" POUR UN INTERVALLE 52 : * D'INTEGRATION DONNE. 53 : * F5F6 = SUITE D'ORDONNEES POUR UN INTERVALLE D'INTEGRATION DONNE. 54 : * F0 = 1ERE VALEUR DE "F" SUR L'INTERVALLE OU ELLE EST DEFINIE. 55 : * F8 = DERNIERE VALEUR DE "F". 56 : * L56MAX = LONGUEUR MAXI DES TABLES DE TRAVAIL "X5X6" ET "F5F6". 57 : * NBFONC = NOMBRE DE PAS DE DISCRETISATION POUR LES FONCTIONS "F". 58 : * NBSOMM = NOMBRE DE PAS DE DISCRETISATION POUR LES FONCTIONS 59 : * INTEGRALES "G". 60 : * NEAR5S = X5 TRES VOISIN DE L'ABSCISSE SUIVANTE DANS LA LISTE. 61 : * NEAR6P = X6 TRES VOISIN DE L'ABSCISSE PRECEDENTE DANS LA LISTE. 62 : * NEAR6S = X6 TRES VOISIN DE L'ABSCISSE SUIVANTE DANS LA LISTE. 63 : * X5X6 = SUITE D'ABSCISSES POUR UN INTERVALLE D'INTEGRATION DONNE. 64 : * 65 : POINTEUR X5X6.MLREEL,F5F6.MLREEL 66 : LOGICAL NEAR5S,NEAR6P,NEAR6S 67 : COMMON /CSOMM1/ F0,F8,F6,A6,M6,NBFONC,NEAR6P,NEAR6S 68 : * 69 : * FONCTIONS: 70 : * ---------- 71 : * 72 : LOGICAL EGALDP 73 : REAL*8 SOMME2,SOMME4 74 : * 75 : * MODE DE FONCTIONNEMENT: 76 : * ----------------------- 77 : * 78 : * LES FONCTIONS D'ENTREES SONT SUPPOSEES CONSTANTES SUR LES 79 : * INTERVALLES OU ELLES NE SONT PAS DEFINIES, ET EGALES AUX VALEURS 80 : * AUX BORNES OU ELLES SONT DEFINIES. 81 : * 82 : * L'INTERVALLE "DX" EST SUPPOSE TRES PETIT DEVANT L'INTERVALLE DE 83 : * DEFINITION DES FONCTIONS ET "X0" EST SUPPOSE PROCHE DE LA 1ERE 84 : * ABSCISSE OU SONT DEFINIES LES FONCTIONS. CE QUI FAIT QUE LA 85 : * LOCALISATION DE "X0" ET DES INTERVALLES (X-DX,X) DANS L'INTERVALLE 86 : * DE DEFINITION DES FONCTIONS SE FONT PAR TESTS SUCCESSIFS DANS UN 87 : * ORDRE MONOTONE DANS LE SENS DES ABSCISSES CROISSANTES. 88 : * 89 : * REMARQUES: 90 : * ---------- 91 : * 92 : * ON GARDE LES TYPES ET TITRES DES FONCTIONS POUR LES INTEGRALES 93 : * ASSOCIEES. 94 : * 95 : * AUTEUR, DATE DE CREATION: 96 : * ------------------------- 97 : * 98 : * PASCAL MANIGOT 29 MARS 1988 99 : * 100 : * LANGAGE: 101 : * -------- 102 : * 103 : * ESOPE + FORTRAN77 104 : * 105 : ************************************************************************ 106 : * 107 : NBSOMM = NINT( (X8-X0)/DX ) 108 : JG = NBSOMM 109 : * 110 : MEVOL1 = KFONCT 111 : SEGINI,MEVOLL=MEVOL1 112 : KSOMME = MEVOLL 113 : NEVOLL = IEVOLL(/1) 114 : SEGACT,MEVOL1 115 : * 116 : * 117 : DO 100 IB=1,NEVOLL 118 : * 119 : KEVOL1 = IEVOLL(IB) 120 : SEGINI,KEVOLL=KEVOL1 121 : IEVOLL(IB) = KEVOLL 122 : * 123 : IF (IB .EQ. 1) THEN 124 : SEGINI,MLREEL 125 : X = X0 126 : DO 120 IB2=1,NBSOMM 127 : X = X + DX 128 : PROG(IB2) = X 129 : 120 CONTINUE 130 : * END DO 131 : END IF 132 : SEGINI,MLREE1 133 : IPROGX = MLREEL 134 : IPROGY = MLREE1 135 : * 136 : 100 CONTINUE 137 : * END DO 138 : * 139 : * A CE NIVEAU, 140 : * "MLREEL" EST TOUJOURS ACTIF ET REPRESENTE LA LISTE DES ABSCISSES 141 : * POUR CHAQUE FONCTION INTEGRALE. 142 : * LES "IPROGY" SONT TOUS ACTIFS. 143 : * 144 : L56MAX = 100 145 : JG = L56MAX 146 : SEGINI,X5X6,F5F6 147 : * 148 : * 149 : DO 200 IB=1,NEVOLL 150 : * 151 : KEVOLL = IEVOLL(IB) 152 : MLREE1 = IPROGY 153 : KEVOL1 = MEVOL1.IEVOLL(IB) 154 : SEGACT,KEVOL1 155 : MLREE2 = KEVOL1.IPROGX 156 : MLREE3 = KEVOL1.IPROGY 157 : SEGACT,MLREE2,MLREE3 158 : NBFONC = MLREE2.PROG(/1) 159 : * 160 : F0 = MLREE3.PROG(1) 161 : S0 = F0 * DX 162 : F8 = MLREE3.PROG(NBFONC) 163 : S8 = F8 * DX 164 : * 165 : X6 = X0 165 : CALL PLACE3 (MLREE2.PROG,1,NBFONC,X6, M6,A6) 165 : CALL SOMME3 (MLREE3.PROG) 166 : * 167 : DO 300 ISOMME=1,NBSOMM 168 : * 169 : IF (M6 .GE. NBFONC) THEN 170 : * 171 : S6 = S8 172 : * 173 : ELSE 174 : * 175 : X5 = X6 176 : F5 = F6 177 : M5 = M6 178 : A5 = A6 179 : X6 = X5 + DX 180 : * 181 : INF = MAX (1,M5) 181 : CALL PLACE3 (MLREE2.PROG,INF,NBFONC,X6, M6,A6) 182 : * 183 : IF (M6 .LT. INF) THEN 184 : * 185 : S6 = S0 186 : * PREPARATION POUR LES "ISOMME" SUIVANTS: 186 : CALL SOMME3 (MLREE3.PROG) 187 : * 188 : ELSE 189 : * 190 : NEAR5S = NEAR6S 190 : CALL SOMME3 (MLREE3.PROG) 191 : * 192 : JG = M6 - M5 + 2 193 : IF (NEAR5S) THEN 194 : JG = JG - 1 195 : END IF 196 : IF (NEAR6P) THEN 197 : JG = JG - 1 198 : END IF 199 : IF (JG .LT. 2) THEN 200 : * X5 ET X6 SONT TROP VOISINS PAR RAPPORT A LA 201 : * DISCRETISATION LOCALE DE LA FONCTION. 201 : CALL ERREUR (419) 202 : RETURN 203 : END IF 204 : IF (JG .GT. L56MAX) THEN 205 : SEGADJ,X5X6 206 : SEGADJ,F5F6 207 : L56MAX = JG 208 : END IF 209 : * 210 : X5X6.PROG(1) = X5 211 : F5F6.PROG(1) = F5 212 : IF (NEAR5S) THEN 213 : I0 = M5 214 : ELSE 215 : I0 = M5 - 1 216 : END IF 217 : DO 320 IB3=2,(JG-1) 218 : X5X6.PROG(IB3) = MLREE2.PROG(I0+IB3) 219 : F5F6.PROG(IB3) = MLREE3.PROG(I0+IB3) 220 : 320 CONTINUE 221 : * END DO 222 : X5X6.PROG(JG) = X6 223 : F5F6.PROG(JG) = F6 224 : * 225 : S6 = SOMME2 (X5X6.PROG,F5F6.PROG,JG) 226 : * 227 : END IF 228 : * 229 : END IF 230 : * 231 : MLREE1.PROG(ISOMME) = S6 232 : * 233 : 300 CONTINUE 234 : * END DO 235 : * 236 : SEGDES,KEVOLL,MLREE1 237 : SEGDES,KEVOL1,MLREE2,MLREE3 238 : * 239 : 200 CONTINUE 240 : * END DO 241 : * 242 : SEGDES,MEVOLL,MLREEL 243 : SEGDES,MEVOL1 244 : SEGSUP,X5X6,F5F6 245 : * 246 : END 247 :
© Cast3M 2003 - All rights reserved.
Disclaimer