Télécharger opobje.eso

Retour à la liste

opobje
C OPOBJE    SOURCE    CB215821  23/10/18    21:15:09     11760          
      SUBROUTINE OPOBJE(IOPERA)
C----------------------------------------------------------------------C
C Cette source permet de faire les opérations elementaires sur
C les OBJETS suivants :
C  - MCHAML
C  - CHPOINT
C  - LISTREEL
C  - FLOTTANT
C  - EVOLUTION (travail effectue sur les ordonnees seulement)
C               Nouveau 2014 ==> Certaines fonctions ne le geraient pas
C  - LISTENTI  (Nouveau 2014 ==> Renvoie un LISTREEL sauf pour ABS)
C  - ENTIER    (Nouveau 2014 ==> Renvoie un FLOTTANT sauf pour ABS)
C
C
C  ENTREE
C Operations elementaires entre les OBJETS et un ENTIER ou FLOTTANT
C     IOPERA= 1  PUISSANCE
C           = 2  PRODUIT
C           = 3  ADDITION
C           = 4  SOUSTRACTION
C           = 5  DIVISION
C
C Fonctions sur les OBJETS
C     IOPERA= 6  COSINUS
C           = 7  SINUS
C           = 8  TANGENTE
C           = 9  ARCOSINUS
C           = 10 ARCSINUS
C           = 11 ARCTANGENTE
C           = 12 EXPONENTIELLE
C           = 13 LOGARITHME
C           = 14 VALEUR ABSOLUE
C           = 15 COSINUS  HYPERBOLIQUE
C           = 16 SINUS    HYPERBOLIQUE
C           = 17 TANGENTE HYPERBOLIQUE
C           = 18 ERF  FONCTION D''ERRREUR DE GAUSS
C           = 19 ERFC FONCTION D''ERRREUR complementaire DE GAUSS (1-erf(x))
C           = 20 ARGCH (Fonction reciproque de COSH)
C           = 21 ARGSH (Fonction reciproque de SINH)
C           = 22 ARGTH (Fonction reciproque de TANH)
C           = 23 SIGN  (renvoie -1 ou +1, resultat du meme type)
C           = 24 BESSEL J0
C           = 25 BESSEL J1
C           = 26 BESSEL Y0
C           = 27 BESSEL Y1
C           = 28 FRESNEL CX
C           = 29 FRESNEL SX
C           = 30 GAMMA (Fonction Gamma d'Euler)
C           = 31 BESSEL JN
C           = 32 BESSEL YN
C
C     IARGU = 0  ==> ARGUMENT I1  ET FLO INUTILISES
C     IARGU = 1  ==> ARGUMENT I1  UTILISE
C     IARGU = 11 ==> ARGUMENT I1  UTILISE MAIS COMMUTE AVEC LE TABLEAU (SOUSTRACTION, DIVISION : POSITIONNEL)
C     IARGU = 2  ==> ARGUMENT FLO UTILISE
C     IARGU = 21 ==> ARGUMENT FLO UTILISE MAIS COMMUTE AVEC LE TABLEAU (SOUSTRACTION, DIVISION : POSITIONNEL)
C
C HISTORIQUE :
C   - CB215821             24/07/2014  --> Remise en conformite
C   - CB215821             10/12/2015  --> Parallelisation des operations sur les CHPOINTS
C   - CB215821             31/08/2016  --> Mise a jour des Commentaires
C   - CB215821             05/06/2018  --> Ajout de la fonction SIGN a un argument
C   - CB215821             17/10/2023  --> Ajout des fonctions BESSEL, FRESNEL et GAMMA
C----------------------------------------------------------------------C
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
 
      PARAMETER  (NCLEVO = 2)
      CHARACTER*4 CLEVO(NCLEVO)
      DATA        CLEVO/'ABSC','ORDO'/
 
      LOGICAL BATAN2
 
      INTEGER IPO1,IPO2,IR1,IR2,IOUT,IOPERA
      INTEGER IARGU,I1,IRET
 
      REAL*8  XR,XR1,XR2,XOUT,FLO
      REAL*8  XVAL(3)
 
 
 
C-INC CCREEL
 
-INC PPARAM
-INC CCOPTIO
-INC SMLREEL
-INC SMLENTI
 
      BATAN2 = .FALSE.
 
      IRET   = 0
      IPO1   = 0
      IPO2   = 0
      IOUT   = 0
      IR1    = 0
      IR2    = 0
      XR     = REAL(0.D0)
      XR1    = REAL(0.D0)
      XR2    = REAL(0.D0)
      XOUT   = REAL(0.D0)
 
C     IARGU  = 0 pour ignorer I1 et FLO
      IARGU  = 0
      I1     = 0
      FLO    = REAL(0.D0)
 
 
C     Cas des fonctions de Bessel JN et YN
      IF(IOPERA.EQ.31 .OR. IOPERA.EQ.32)THEN
C       Lecture obligatoire d'un 'ENTIER' pour l'ordre
        CALL LIRENT(I1,1,IRETOU)
        IF(IERR .NE. 0)RETURN
        IARGU = 1
      ENDIF
 
C
C     CAS DU MCHAML
      CALL LIROBJ('MCHAML  ',IPO1,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 10
      CALL ACTOBJ('MCHAML  ',IPO1,1)
      CALL LIROBJ('MCHAML  ',IPO2,0,IRETOU)
      IF(IRETOU .NE. 0) CALL ACTOBJ('MCHAML  ',IPO2,1)
      CALL OPCHE1(IPO1,IOPERA,IARGU,I1,FLO,IPO2,IRET)
      IF(IRET .EQ. 1) THEN
        CALL ACTOBJ('MCHAML  ',IPO2,1)
        CALL ECROBJ('MCHAML  ',IPO2)
      ELSE
        CALL ERREUR(26)
      ENDIF
      RETURN
C
C     CAS DU CHPOINT
 10   CONTINUE
      CALL LIROBJ('CHPOINT ',IPO1,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 20
      CALL ACTOBJ('CHPOINT ',IPO1,1)
      CALL LIROBJ('CHPOINT',IPO2,0,IRETOU)
      IF (IRETOU.NE.0) THEN
        CALL ACTOBJ('CHPOINT ',IPO2,1)
C       Pour l'instant l'ATAN2 a 2 arguments est realisee en Sequentiel...
        CALL OPCHPO(IPO1,IOPERA,IPO2)
      ELSE
        CALL OPCHP1(IPO1,IOPERA,IARGU,I1,FLO,IPO2,IRET)
        IF(IRET .EQ. 0) THEN
          CALL ERREUR(26)
          RETURN
        ENDIF
      ENDIF
      CALL ACTOBJ('CHPOINT ',IPO2,1)
      CALL ECROBJ('CHPOINT ',IPO2)
      RETURN
C
C     CAS D''UN LISTREEL
 20   CONTINUE
      CALL LIROBJ('LISTREEL',IPO1,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 25
      MLREEL=IPO1
      SEGACT,MLREEL
      CALL LIROBJ('LISTREEL',IPO2,0,IRETOU)
      IF(IRETOU .NE. 0)THEN
        MLREEL=IPO2
        SEGACT,MLREEL
      ENDIF
      CALL OPLRE1(IPO1,IOPERA,IARGU,I1,FLO,IPO2,IRET)
      IF(IRET .EQ. 0) THEN
        CALL ERREUR(26)
        RETURN
      ENDIF
      MLREEL=IPO2
      SEGACT,MLREEL
      CALL ECROBJ('LISTREEL',IPO2)
      RETURN
C
C     CAS D''UN ENTIER
 25   CONTINUE
      CALL LIRENT(IR1,0,IRETOU)
      IF(IRETOU.EQ.0) GO TO 30
      IF (IOPERA .EQ. 11) THEN
        CALL LIRENT(IR2,0,IRETO2)        
        IF(IRETO2.NE.0) THEN
          BATAN2 = .TRUE.
        ELSE
          IR2 = 0.D0
        ENDIF
      ENDIF
 
      CALL OPENTI(IR1,IR2,BATAN2,IOPERA,IOUT,XOUT)
 
C     Resultat ENTIER attendu pour ABS (IOPERA = 14 OU 23)
      IF (IOPERA .EQ. 14 .OR. IOPERA .EQ. 23) THEN
        CALL ECRENT(IOUT)
      ELSE
        CALL ECRREE(XOUT)
      ENDIF
      RETURN
C
C     CAS D''UN FLOTTANT
 30   CONTINUE
      CALL LIRREE(XR1,0,IRETOU)
      IF(IRETOU.EQ.0) GO TO 40
 
      NN0    = 1
      NTABEN = 1
      XVAL(1)= XR1
      IF (IOPERA .EQ. 11) THEN
C       Cas de ARCTANGENTE : on essaye de lire un deuxieme argument ==> ATAN
        CALL LIRREE(XR2,0,IRETO2)
        IF(IRETO2 .NE. 0)THEN
          NTABEN = 2
          XVAL(2)= XR2
        ENDIF
      ENDIF
 
      CALL OPTABJ(1 ,0,IOPERA,NTABEN,
     &          XVAL(1),XVAL(2),XVAL(3),
     &          NN0  ,NN0  ,NN0  ,0 ,0  ,0.D0 ,IRETOU)
 
      CALL ECRREE(XVAL(3))
      RETURN
 
C     EVOLUTION
  40  CONTINUE
      CALL LIROBJ('EVOLUTIO',IPO1,0,IRETOU)
      IF (IRETOU.EQ.0) GO TO 50
      CALL ACTOBJ('EVOLUTIO',IPO1,1)
C      Pas tres clair de donner 2 arguments pour ATAN avec des EVOLUTIONS
C      Du coup un seul sera accepté
C      IF (IOPERA .EQ. 11) CALL LIROBJ('EVOLUTIO',IPO2,0,IRETOU)
      ICLE = 0
      CALL LIRMOT(CLEVO,NCLEVO,ICLE,0)
      IF (ICLE.EQ.0) ICLE = 2
      CALL OPEVO1(IPO1,IOPERA,IARGU,ICLE,I1,FLO,IPO2,IRET)
      IF(IRET .EQ. 0) THEN
        CALL ERREUR(26)
        RETURN
      ENDIF
      CALL ACTOBJ('EVOLUTIO',IPO2,1)
      CALL ECROBJ('EVOLUTIO',IPO2)
      RETURN
C
C     CAS D''UN LISTENTI
 50   CONTINUE
      CALL LIROBJ('LISTENTI',IPO1,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 60
      MLENTI=IPO1
      SEGACT,MLENTI
      IF (IOPERA .EQ. 11) THEN
        CALL LIROBJ('LISTENTI',IPO2,0,IRETOU)
        IF(IRETOU .NE. 0) THEN
          MLENTI=IPO2
          SEGACT,MLENTI
        ENDIF
      ENDIF
      CALL OPLENT(IPO1,IOPERA,IPO2)
C     Resultat LISTENTI attendu pour ABS (IOPERA = 14 OU 23)
      IF (IOPERA .EQ. 14 .OR. IOPERA .EQ. 23) THEN
        MLENTI=IPO2
        SEGACT,MLENTI
        CALL ECROBJ('LISTENTI',IPO2)
      ELSE
        MLREEL=IPO2
        SEGACT,MLREEL
        CALL ECROBJ('LISTREEL',IPO2)
      ENDIF
      RETURN
C
C    PAS D''OPERANDE CORRECTE TROUVE
 60   CALL QUETYP(MOTERR(1:8),0,IRETOU)
      IF(IRETOU.NE.0) THEN
         CALL ERREUR (39)
      ELSE
         CALL ERREUR(533)
      ENDIF
 
      END
 
 
 
 
 

© Cast3M 2003 - Tous droits réservés.
Mentions légales