Sources Esope | Cast3M

somme1
C SOMME1    SOURCE    CHAT      05/01/13    03:22:02     5004
      SUBROUTINE SOMME1 (KFONCT,X0,X8,DX,  KSOMME)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
************************************************************************
*
*                             S O M M E 1
*                             -----------
*
* FONCTION:
* ---------
*
*     CREATION, A PARTIR DE FONCTIONS "F", LES FONCTIONS "G" TELLES:
*
*                 X
*               /
*     G(X) =   /   F(T).DT
*             /
*           X-DX
*
*     CES FONCTIONS ETANT TOUTES DEFINIES PAR DES SUITES DE COUPLES DE
*     VALEURS (X,F(X)), ORDONNES STRICTEMENT SELON LES "X" CROISSANTS.
*
* MODULES UTILISES:
* -----------------
*
-INC SMEVOLL
-INC SMLREEL
*
* PARAMETRES:   (E)=ENTREE   (S)=SORTIE   (+ = CONTENU DANS UN COMMUN)
* -----------
*
*     KFONCT  (E)  OBJET "EVOLUTION" REPRESENTANT LES FONCTIONS A
*                  INTEGRER.
*     X0, X8  (E)  INTERVALLE TOTAL SUR LEQUEL LES FONCTIONS SERONT
*                  INTEGREES.
*     DX      (E)  LONGUEUR DES INTERVALLES D'INTEGRATION.
*                  LES FONCTIONS INTEGRALES PRENDRONT DONC LEUR 1ERE
*                  VALEUR EN X0+DX ET LEUR DERNIERE VALEUR AUTOUR DE
*                  X8 (SELON DX).
*     KSOMME  (S)  OBJET "EVOLUTION" REPRESENTANT LES FONCTIONS
*                  INTEGRALES.
*
      REAL*8 X0,X8,DX
*
* VARIABLES:
* ----------
*
*     5      = INDICE SIGNIFIANT "BORNE INFERIEURE" POUR UN INTERVALLE
*              D'INTEGRATION DONNE.
*     6      = INDICE SIGNIFIANT "BORNE SUPERIEURE" POUR UN INTERVALLE
*              D'INTEGRATION DONNE.
*     F5F6   = SUITE D'ORDONNEES POUR UN INTERVALLE D'INTEGRATION DONNE.
*     F0     = 1ERE VALEUR DE "F" SUR L'INTERVALLE OU ELLE EST DEFINIE.
*     F8     = DERNIERE VALEUR DE "F".
*     L56MAX = LONGUEUR MAXI DES TABLES DE TRAVAIL "X5X6" ET "F5F6".
*     NBFONC = NOMBRE DE PAS DE DISCRETISATION POUR LES FONCTIONS "F".
*     NBSOMM = NOMBRE DE PAS DE DISCRETISATION POUR LES FONCTIONS
*              INTEGRALES "G".
*     NEAR5S = X5 TRES VOISIN DE L'ABSCISSE SUIVANTE DANS LA LISTE.
*     NEAR6P = X6 TRES VOISIN DE L'ABSCISSE PRECEDENTE DANS LA LISTE.
*     NEAR6S = X6 TRES VOISIN DE L'ABSCISSE SUIVANTE DANS LA LISTE.
*     X5X6   = SUITE D'ABSCISSES POUR UN INTERVALLE D'INTEGRATION DONNE.
*
      POINTEUR X5X6.MLREEL,F5F6.MLREEL
      LOGICAL NEAR5S,NEAR6P,NEAR6S
      COMMON /CSOMM1/ F0,F8,F6,A6,M6,NBFONC,NEAR6P,NEAR6S
*
* FONCTIONS:
* ----------
*
      LOGICAL EGALDP
      REAL*8 SOMME2,SOMME4
*
* MODE DE FONCTIONNEMENT:
* -----------------------
*
*     LES FONCTIONS D'ENTREES SONT SUPPOSEES CONSTANTES SUR LES
*     INTERVALLES OU ELLES NE SONT PAS DEFINIES, ET EGALES AUX VALEURS
*     AUX BORNES OU ELLES SONT DEFINIES.
*
*     L'INTERVALLE "DX" EST SUPPOSE TRES PETIT DEVANT L'INTERVALLE DE
*     DEFINITION DES FONCTIONS ET "X0" EST SUPPOSE PROCHE DE LA 1ERE
*     ABSCISSE OU SONT DEFINIES LES FONCTIONS. CE QUI FAIT QUE LA
*     LOCALISATION DE "X0" ET DES INTERVALLES (X-DX,X) DANS L'INTERVALLE
*     DE DEFINITION DES FONCTIONS SE FONT PAR TESTS SUCCESSIFS DANS UN
*     ORDRE MONOTONE DANS LE SENS DES ABSCISSES CROISSANTES.
*
* REMARQUES:
* ----------
*
*     ON GARDE LES TYPES ET TITRES DES FONCTIONS POUR LES INTEGRALES
*     ASSOCIEES.
*
* AUTEUR, DATE DE CREATION:
* -------------------------
*
*     PASCAL MANIGOT     29 MARS 1988
*
* LANGAGE:
* --------
*
*     ESOPE + FORTRAN77
*
************************************************************************
*
      NBSOMM = NINT( (X8-X0)/DX )
      JG = NBSOMM
*
      MEVOL1 = KFONCT
      SEGINI,MEVOLL=MEVOL1
      KSOMME = MEVOLL
      NEVOLL = IEVOLL(/1)
      SEGACT,MEVOL1
*
*
      DO 100 IB=1,NEVOLL
*
         KEVOL1 = IEVOLL(IB)
         SEGINI,KEVOLL=KEVOL1
         IEVOLL(IB) = KEVOLL
*
         IF (IB .EQ. 1) THEN
            SEGINI,MLREEL
            X = X0
            DO 120 IB2=1,NBSOMM
               X = X + DX
               PROG(IB2) = X
  120          CONTINUE
*           END DO
         END IF
         SEGINI,MLREE1
         IPROGX = MLREEL
         IPROGY = MLREE1
*
  100    CONTINUE
*     END DO
*
*     A CE NIVEAU,
*     "MLREEL" EST TOUJOURS ACTIF ET REPRESENTE LA LISTE DES ABSCISSES
*     POUR CHAQUE FONCTION INTEGRALE.
*     LES "IPROGY" SONT TOUS ACTIFS.
*
      L56MAX = 100
      JG = L56MAX
      SEGINI,X5X6,F5F6
*
*
      DO 200 IB=1,NEVOLL
*
         KEVOLL = IEVOLL(IB)
         MLREE1 = IPROGY
         KEVOL1 = MEVOL1.IEVOLL(IB)
         SEGACT,KEVOL1
         MLREE2 = KEVOL1.IPROGX
         MLREE3 = KEVOL1.IPROGY
         SEGACT,MLREE2,MLREE3
         NBFONC = MLREE2.PROG(/1)
*
         F0 = MLREE3.PROG(1)
         S0 = F0 * DX
         F8 = MLREE3.PROG(NBFONC)
         S8 = F8 * DX
*
         X6 = X0
         CALL PLACE3 (MLREE2.PROG,1,NBFONC,X6,  M6,A6)
         CALL SOMME3 (MLREE3.PROG)
*
         DO 300 ISOMME=1,NBSOMM
*
            IF (M6 .GE. NBFONC) THEN
*
               S6 = S8
*
            ELSE
*
               X5 = X6
               F5 = F6
               M5 = M6
               A5 = A6
               X6 = X5 + DX
*
               INF = MAX (1,M5)
               CALL PLACE3 (MLREE2.PROG,INF,NBFONC,X6,  M6,A6)
*
               IF (M6 .LT. INF) THEN
*
                  S6 = S0
*                 PREPARATION POUR LES "ISOMME" SUIVANTS:
                  CALL SOMME3 (MLREE3.PROG)
*
               ELSE
*
                  NEAR5S = NEAR6S
                  CALL SOMME3 (MLREE3.PROG)
*
                  JG = M6 - M5 + 2
                  IF (NEAR5S) THEN
                     JG = JG - 1
                  END IF
                  IF (NEAR6P) THEN
                     JG = JG - 1
                  END IF
                  IF (JG .LT. 2) THEN
*                    X5 ET X6 SONT TROP VOISINS PAR RAPPORT A LA
*                    DISCRETISATION LOCALE DE LA FONCTION.
                     CALL ERREUR (419)
                     RETURN
                  END IF
                  IF (JG .GT. L56MAX) THEN
                     SEGADJ,X5X6
                     SEGADJ,F5F6
                     L56MAX = JG
                  END IF
*
                  X5X6.PROG(1) = X5
                  F5F6.PROG(1) = F5
                  IF (NEAR5S) THEN
                     I0 = M5
                  ELSE
                     I0 = M5 - 1
                  END IF
                  DO 320 IB3=2,(JG-1)
                     X5X6.PROG(IB3) = MLREE2.PROG(I0+IB3)
                     F5F6.PROG(IB3) = MLREE3.PROG(I0+IB3)
  320                CONTINUE
*                 END DO
                  X5X6.PROG(JG) = X6
                  F5F6.PROG(JG) = F6
*
                  S6 = SOMME2 (X5X6.PROG,F5F6.PROG,JG)
*
               END IF
*
            END IF
*
            MLREE1.PROG(ISOMME) = S6
*
  300       CONTINUE
*        END DO
*
         SEGDES,KEVOLL,MLREE1
         SEGDES,KEVOL1,MLREE2,MLREE3
*
  200    CONTINUE
*     END DO
*
      SEGDES,MEVOLL,MLREEL
      SEGDES,MEVOL1
      SEGSUP,X5X6,F5F6
*
      END