Télécharger opevo1.eso

Retour à la liste

opevo1
C OPEVO1    SOURCE    PASCAL    22/07/13    21:15:08     11409          
      SUBROUTINE OPEVO1(IPO1,IOPERA,IARGU,ICLE,I1,X1,IPO2,IRET)
C=======================================================================
C
C  ENTREES
C     IPO1  = POINTEUR SUR LE EVOLUTIO
C     I1    = ENTIER
C     X1    = FLOTTANT
C
C
C Operations elementaires entre un EVOLUTIO 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 EVOLUTIO
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     ICLE  = 1 operation sur les abscisses
C     ICLE  = 2 operation sur les ordonnees (defaut)
C
C  SORTIES
C     IPO2  = EVOLUTIO SOLUTION
C     IRET  = 1 SI L OPERATION EST POSSIBLE
C           = 0 SI L OPERATION EST IMPOSSIBLE
C
C HISTORIQUE :
C   - CB215821             07/12/2015  --> Creation
C   - CB215821             01/09/2016  --> Ajout de l''include TMVALUE
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 PPARAM
-INC CCOPTIO
-INC SMEVOLL
-INC SMLREEL
-INC SMLENTI
-INC SMLMOTS
-INC CCASSIS
-INC TMVALUE
 
      CHARACTER*8 CTYP
 
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
 
C======================================================================C
C     Activation des SEGMENTS pour placer les LISTREEL dans le SVALUE
C======================================================================C
      MEVOL1=IPO1
 
      SEGINI,MEVOLL=MEVOL1
      IPO2 = MEVOLL
 
      N=MEVOLL.IEVOLL(/1)
      IF (N .EQ. 0)THEN
C       Cas de l'EVOLUTION vide
        IRET = 1
        RETURN
      ENDIF
 
C     Regalge fait sur PC40 pour determiner le nombre de NOEUDS optimum
C     par thread
      IOPTIM = 100
 
      IPOS1 = 0
      NBPOIN=N
      SEGINI,SVALUE
 
      DO 40 IA=1,N
        KEVOL1=MEVOLL.IEVOLL(IA)
        SEGINI,KEVOLL=KEVOL1
        MEVOLL.IEVOLL(IA)=KEVOLL
 
        IF (ICLE.EQ.1) THEN
          CTYP = KEVOLL.TYPX 
          IPRG = KEVOLL.IPROGX
        ELSE
C         Les ordonnees dans tout autre cas :
          CTYP = KEVOLL.TYPY 
          IPRG = KEVOLL.IPROGY
        ENDIF
 
        IF     (CTYP .EQ. 'LISTMOTS') THEN
C         Cas des ordonnees de type LISTMOTS
C         Cela sert pour DESS pour mettre les petits triangles au niveau
C         des points nommes sur l''abscisse curviligne
          GOTO 40
 
        ELSEIF (CTYP .EQ. 'LISTREEL') THEN
C         Cas des ordonnees de type LISTREEL
          MLREE1=IPRG
          JG =MLREE1.PROG(/1)
          SEGINI,MLREEL
          IF (ICLE.EQ.1) THEN
            KEVOLL.IPROGX=MLREEL
          ELSE
            KEVOLL.IPROGY=MLREEL
          ENDIF
          IPOS1  = IPOS1 + 1
          SVALUE.ITYPOI (IPOS1  )= 3
          SVALUE.IPOI0  (IPOS1,1)= MLREE1
          SVALUE.IPOI1  (IPOS1,1)= 0
          SVALUE.IPOI2  (IPOS1,1)= MLREEL
          SVALUE.IPOI0  (IPOS1,2)= JG
          SVALUE.IPOI1  (IPOS1,2)= 0
          SVALUE.IPOI2  (IPOS1,2)= JG
 
        ELSEIF(CTYP .EQ. 'LISTENTI') THEN
C         Cas des ordonnees de type LISTENTI
          MLENT1=IPRG
          JG =MLENT1.LECT(/1)
          SEGINI,MLENTI
          IF (ICLE.EQ.1) THEN
            KEVOLL.IPROGX=MLENTI
          ELSE
            KEVOLL.IPROGY=MLENTI
          ENDIF
          IPOS1  = IPOS1 + 1
          SVALUE.ITYPOI (IPOS1  )= 4
          SVALUE.IPOI0  (IPOS1,1)= MLENT1
          SVALUE.IPOI1  (IPOS1,1)= 0
          SVALUE.IPOI2  (IPOS1,1)= MLENTI
          SVALUE.IPOI0  (IPOS1,2)= JG
          SVALUE.IPOI1  (IPOS1,2)= 0
          SVALUE.IPOI2  (IPOS1,2)= JG
 
        ELSE
C         Cas des ordonnees de type Different
          MOTERR(1:8) = CTYP
          IF (IARGU .EQ. 1 .OR. IARGU .EQ. 11) THEN
            MOTERR(9:16)='ENTIER  '
            CALL ERREUR(532)
          ELSEIF (IARGU .EQ. 2 .OR. IARGU .EQ. 21) THEN
            MOTERR(9:16)='FLOTTANT'
            CALL ERREUR(532)
          ELSE
            MOTERR(9:16)='????    '
            CALL ERREUR(532)
          ENDIF
          RETURN
        ENDIF
 
        IF (IA .EQ. 1) THEN
          NT1 = JG / IOPTIM
        ELSE
          NT1 = MAX(NT1, JG/IOPTIM)
        ENDIF
  40  CONTINUE
      SVALUE.NPUTIL=IPOS1
 
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
 
 
 
 
 
 

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