Sources Esope | Cast3M

oplre1
C OPLRE1    SOURCE    PV        20/04/28    21:15:22     10593          
      SUBROUTINE OPLRE1(IPO1,IOPERA,IARGU,I1,X1,IPO2,IRET)
C=======================================================================
C
C  ENTREES
C     IPO1  = POINTEUR SUR LE LISTREEL
C     IPO2  = POINTEUR SUR LE LISTREEL (Second Argument + - * / ATAN2)
C     I1    = ENTIER
C     X1    = FLOTTANT
C
C Operations elementaires entre un LISTREEL 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 un LISTREEL
C     IOPERA= 6  COSINUS
C           = 7  SINUS
C           = 8  TANGENTE
C           = 9  ARCOSINUS
C           = 10 ARCSINUS
C           = 11 ARCTANGENTE (ATAN A UN ARGUMENT)
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
C     IARGU = 0  ==> ARGUMENT I1I ET X1I INUTILISES
C     IARGU = 1  ==> ARGUMENT I1I UTILISE
C     IARGU = 11 ==> ARGUMENT I1I UTILISE MAIS COMMUTE AVEC LE TABLEAU (SOUSTRACTION, DIVISION : POSITIONNEL)
C     IARGU = 2  ==> ARGUMENT X1I UTILISE
C     IARGU = 21 ==> ARGUMENT X1I UTILISE MAIS COMMUTE AVEC LE TABLEAU (SOUSTRACTION, DIVISION : POSITIONNEL)
C
C  SORTIES
C     IPO2  = LISTREEL SOLUTION
C     IRET  = 1 SI L OPERATION EST POSSIBLE
C           = 0 SI L OPERATION EST IMPOSSIBLE
C
C HISTORIQUE :
C   - CB215821             05/09/2016  --> Creation
C   - CB215821             05/06/2018  --> Ajout de la fonction SIGN a un argument
C
C=======================================================================
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
 
-INC SMLREEL
-INC CCASSIS
-INC TMVALUE
 
C     Segment quelconque pour la desactivation des segements
      SEGMENT ISEG(0)
 
      EXTERNAL OPTABi
      LOGICAL  BTHRD
 
C      Pour afficher les lignes gibianes appelees decommenter le CALL
C      CALL TRBAC
 
      MLREE2 = 0
 
C======================================================================C
C     Activation des SEGMENTS pour placer les PROG dans le SVALUE
C======================================================================C
      MLREE1=IPO1
      JG=MLREE1.PROG(/1)
 
C     Ajout lecture second argument
      IF (IPO2 .GT. 0) THEN
        MLREE2=IPO2
        IF (IPO2 .NE. IPO1) THEN
          JG2=MLREE2.PROG(/1)
C         Les deux objets doivent etre de meme taille
          IF (JG .NE. JG2 ) THEN
            CALL ERREUR(217)
            RETURN
          ENDIF
        ENDIF
      ENDIF
 
      SEGINI,MLREEL
      IPO2=MLREEL
      IF (JG .EQ. 0)THEN
C       Cas du LISTREEL vide : Nouveau pointeur, vide...
        IRET = 1
        RETURN
      ENDIF
 
C     Regalge fait sur PC40 pour determiner le nombre de NOEUDS optimum
C     par thread
      IOPTIM = 100
 
      NBPOIN=1
      SEGINI,SVALUE
      SVALUE.ITYPOI (1  )= 3
      SVALUE.IPOI0  (1,1)= MLREE1
      SVALUE.IPOI1  (1,1)= MLREE2
      SVALUE.IPOI2  (1,1)= MLREEL
      SVALUE.IPOI0  (1,2)= JG
      SVALUE.IPOI1  (1,2)= JG
      SVALUE.IPOI2  (1,2)= JG
      NT1 = JG / IOPTIM
      SVALUE.NPUTIL=NBPOIN
 
C======================================================================C
C      Partie pour lancer le travail sur les Threads en parallele
C======================================================================C
      ITH = 0
      IF (NBESC .NE. 0) ith=oothrd
C       CB215821 : DESACTIVE LA PARALLELISATION PTHREAD LORSQUE ON EST
C                  DEJA DANS LES ASSISTANTS
      IF ((NT1 .LE. 1) .OR. (NBTHRS .EQ. 1) .OR. (ITH .GT. 0)) THEN
        NBTHR = 1
        BTHRD = .FALSE.
      ELSE
        NBTHR = MIN(NT1, NBTHRS)
        BTHRD = .TRUE.
        CALL THREADII
      ENDIF
 
      SEGINI,SPARAL
      SPARAL.NBTHRD = NBTHR
      SPARAL.IVALUE = SVALUE
      SPARAL.IOPE   = IOPERA
      SPARAL.IARG   = IARGU
      SPARAL.I1I    = I1
      SPARAL.X1I    = X1
 
      IF (BTHRD) THEN
C       Remplissage du 'COMMON/optabc'
        IPARAL=SPARAL
        DO ith=2,NBTHR
          CALL THREADID(ith,OPTABi)
        ENDDO
        CALL OPTABi(1)
 
C       Attente de la fin de tous les threads en cours de travail
        DO ith=2,NBTHR
          CALL THREADIF(ith)
        ENDDO
 
C       On libère les Threads
        CALL THREADIS
 
C       Verification de l'erreur (Apres liberation des THREADS)
        DO ith=1,NBTHR
          IRETOU=SPARAL.IERROR(ith)
          IF (IRETOU .GT. 0) THEN
            CALL ERREUR(IRETOU)
            RETURN
          ENDIF
        ENDDO
 
      ELSE
C       Appel de la SUBROUTINE qui fait le travail
        CALL OPTAB0(1,SPARAL)
 
        IRETOU=SPARAL.IERROR(1)
        IF (IRETOU .GT. 0) THEN
          CALL ERREUR(IRETOU)
          RETURN
        ENDIF
      ENDIF
 
      SEGSUP,SVALUE,SPARAL
 
      IRET = 1
      END