Sources Esope | Cast3M

intgra
C INTGRA    SOURCE    CB215821  23/05/02    21:15:03     11661          
 
C---------------------------------------------------------------------
C
C                         OPERATEUR INTG
C
C---------------------------------------------------------------------
C
C     SYNTAXES : voir notice INTG.
C
C---------------------------------------------------------------------
 
      SUBROUTINE INTGRA
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
-INC SMCHAML
-INC SMCOORD
-INC SMLREEL
-INC SMLENTI
 
      CHARACTER*(LOCOMP) MACOMP,MOT1
      CHARACTER*8 CHBOR
      CHARACTER*4 MOTB(4)
      LOGICAL     BDARCY
      INTEGER     IDARC
      DATA MOTB/'INDI','BORN','ELEM','ABSO'/
 
      ilenta=0
C---------------------------------------------------------------------
C     SYNTAXE 1 (par defaut)
C---------------------------------------------------------------------
      IDARC  = 0
      IELEM  = 0
      IRET   = 0
      IPIN   = 0
      IPMODL = 0
      IPCHB1 = 0
      IPCHE2 = 0
      IR     = 0
      KERRE  = 0
      IRT3   = 0
      IPCHE1 = 0
      IPINT  = 0
      XRET   =REAL(0.D0)
      MOT1   ='    '
 
C- Lecture eventuelle du mot cle 'ELEM'
      CALL LIRMOT(MOTB(3),1,IELEM,0)
      IF (IERR.NE.0) RETURN
 
C- Lecture du modele (facultative pour permettre la syntaxe 2)
      CALL LIROBJ('MMODEL  ',IPMODL,0,IRET)
      IF (IERR.NE.0) RETURN
C---- ABSENCE DU MODELE => ON VA TESTER LA SYNTAXE 2 (INTG evol1 ...)
      IF(IRET.EQ.0) GOTO 100
      CALL ACTOBJ('MMODEL  ',IPMODL,1)
 
C- Lecture du MCHAML
      CALL LIROBJ('MCHAML  ',IPIN,1,IRET)
      IF (IERR.NE.0) RETURN
      CALL ACTOBJ('MCHAML  ',IPIN,1)
      IF (IERR.NE.0) RETURN
 
      CALL REDUAF(IPIN,IPMODL,IPCHB1,0,IR,KERRE)
      IF(IR.NE.1) CALL ERREUR(KERRE)
      IF (IERR.NE.0) RETURN
 
C- Lecture eventuelle du nom de la composante du MCHAML a considerer
      CALL LIRCHA(MACOMP,0,IRT3)
      IF (IERR.NE.0) RETURN
 
C- Lecture facultative du MCHAML de CARACTERISTIQUES
      CALL LIROBJ('MCHAML',IPIN,0,IRET)
      IPCHE2=IPIN
      IF((IRET .EQ.1) .AND. (IDARC .EQ. 0))THEN
        CALL ACTOBJ('MCHAML  ',IPIN,1)
        CALL REDUAF(IPIN,IPMODL,IPCHE2,0,IR,KERRE)
        IF(IR.NE.1) CALL ERREUR(KERRE)
        IF (IERR.NE.0) RETURN
      ENDIF
      IF (IERR.NE.0) RETURN
 
C- Dans le cas ou le MCHAML a plus d'une composante
C- on impose la donnee du nom de la composante a traiter.
      IF (IRT3.EQ.0) THEN
        MCHELM=IPCHB1
        N1=ICHAML(/1)
        DO i=1,N1
          MCHAML=ICHAML(I)
          N2=IELVAL(/1)
          IF (N2.GT.1) THEN
            MOTERR(1:8)=' MCHAML '
            INTERR(1)=N2
            CALL ERREUR(761)
            RETURN
          ENDIF
        ENDDO
      ENDIF
 
C- Dans le cas ou le nom de la composante du MCHAML
C- a considerer est precise, on l'extrait du MCHAML.
      IPCHE1=IPCHB1
      IF (IRT3.NE.0) THEN
        MOT1='SCAL'
        CALL EXCOC1(IPCHB1,MACOMP,IPCHE1,MOT1,0)
        IF (IERR.NE.0) RETURN
      ENDIF
 
C- Calcul de l'integrale
      SEGACT,MCOORD
      CALL INTGCA(IPMODL,IPCHE1,IPCHE2,IELEM,IRET,XRET,IPINT)
      SEGDES,MCOORD
      IF (IERR.NE.0) RETURN
 
C- Ecriture du resultat et menage
      IF (IPINT.EQ.0) THEN
        CALL ECRREE(XRET)
      ELSE
        CALL ACTOBJ('MCHAML  ',IPINT,1)
        CALL ECROBJ('MCHAML  ',IPINT)
      ENDIF
 
      RETURN
 
 
C---------------------------------------------------------------------
C     SYNTAXE 2
C---------------------------------------------------------------------
 100  CONTINUE
 
C---  INITIALISATIONS ---
      IABSO      = 0
      IA         = 0
      IB         = 0
      ILENTA     = 0
      ILENTB     = 0
      CHBOR(1:8) ='        '
      IPINT      = 0
      XA         = 0.D0
      XB         = 0.D0
      XINT       = 0.D0
 
C---  LECTURE DES OBJETS EN ENTREE  ---
 
C- Lecture eventuelle du mot cle 'ABS'
      CALL LIRMOT(MOTB(4),-1,IABSO,0)
      IF (IERR.NE.0) RETURN
 
C- Lecture de l'evolution
      CALL LIROBJ('EVOLUTIO',IPEVO,0,IRET)
      IF (IERR.NE.0) RETURN
c---- ABSENCE DE MODELE ET D'EVOLUTION => ERREUR
      IF(IRET.EQ.0) GOTO 998
 
C- Lecture eventuelle des bornes d'integration (de meme type)
      CALL LIRMOT(MOTB,2,ICAS,0)
 
      IF (ICAS.EQ.0) THEN
        ILENTA = 0
        ILENTB = 0
        ILREEA = 0
        ILREEB = 0
 
C     Definition bornes avec indices LISTREEL en abscisses
      ELSEIF (ICAS.EQ.1) THEN
        CALL LIRENT(IA,0,IRETA)
        IF (IRETA.EQ.1) THEN
          CALL LIRENT(IB,1,IRETB)
          IF (IERR.NE.0) RETURN
 
C     Construction de 2 LISTENTI de dime 1
          JG = 1
          SEGINI, MLENT1,MLENT2
          MLENT1.LECT(1) = IA
          MLENT2.LECT(1) = IB
          ILENTA = MLENT1
          ILENTB = MLENT2
          ILREEA = 0
          ILREEB = 0
 
          CHBOR(1:6)='ENTIER'
          GOTO 101
        ELSE
          CALL LIROBJ('LISTENTI',ILENTA,1,IRETA)
          IF (IERR.NE.0) RETURN
          CALL LIROBJ('LISTENTI',ILENTB,1,IRETB)
          IF (IERR.NE.0) RETURN
          CHBOR(1:8)='LISTENTI'
          GOTO 101
        ENDIF
 
C     Definition bornes avec FLOTTANT ou LISTREEL
      ELSEIF (ICAS.EQ.2) THEN
        CALL LIRREE(XA,0,IRETA)
        IF (IRETA.EQ.1) THEN
          CALL LIRREE(XB,1,IRETB)
          IF (IERR.NE.0) RETURN
 
C     Construction de 2 LISTREEL de dime 1
          JG = 1
          SEGINI, MLREE1,MLREE2
          MLREE1.PROG(1) = XA
          MLREE2.PROG(1) = XB
          ILREEA = MLREE1
          ILREEB = MLREE2
          ILENTA = 0
          ILENTB = 0
 
          CHBOR(1:8)='FLOTTANT'
          GOTO 101
        ELSE
          CALL LIROBJ('LISTREEL',ILREEA,1,IRETA)
          IF (IERR.NE.0) RETURN
          CALL LIROBJ('LISTREEL',ILREEB,1,IRETB)
          IF (IERR.NE.0) RETURN
          CHBOR(1:8)='LISTREEL'
          GOTO 101
        ENDIF
 
      ELSE
        CALL ERREUR(5)
        RETURN
      ENDIF
 
C---  CALCUL DE L'INTEGRALE ---
 
 101  CONTINUE
      IK = 0
C     write(6,*) 'ilenta ilentb avant intgev ',ilenta,ilentb
      CALL INTGEV(IPEVO,IABSO,ILENTA,ILENTB,ILREEA,ILREEB,XINT,IPINT,IK)
      IF (IERR.NE.0) RETURN
 
C---  ECRITURE DU RESULTAT ET MENAGE  ---
      IF (IK.EQ.1) THEN
        CALL ECRREE(XINT)
      ELSEIF (IK.EQ.2.AND.IPINT.NE.0) THEN
        CALL ECROBJ('LISTREEL',IPINT)
      ELSEIF (IK.EQ.3.AND.IPINT.NE.0) THEN
        CALL ECROBJ('NUAGE',IPINT)
      ELSE
        CALL ERREUR(5)
      ENDIF
      RETURN
 
 
C---------------------------------------------------------------------
C     SYNTAXE 3 et ...
C---------------------------------------------------------------------
C     ...
 
 
C---------------------------------------------------------------------
C     ERREURS
C---------------------------------------------------------------------
 
* /!\ ERREUR : AUCUN OBJET COMPATIBLE TROUVE
 998  MOTERR(1:16)='MODELE  EVOLUTIO'
      CALL ERREUR(471)
      RETURN
 
      END