Télécharger opche1.eso

Retour à la liste

opche1
C OPCHE1    SOURCE    CB215821  20/11/04    21:19:25     10766          
      SUBROUTINE OPCHE1(IPO1,IOPERA,IARGU,I1,X1,IPO2,IRET)
C=======================================================================
C
C  ENTREES
C     IPO1  = POINTEUR SUR LE MCHELM
C     IPO2  = POINTEUR SUR LE MCHELM (Second Argument ATAN2)
C     I1    = ENTIER
C     X1    = FLOTTANT
C
C Operations elementaires entre un MCHELM 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 MCHELM
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  = MCHELM 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 PPARAM
-INC CCOPTIO
-INC SMCHAML
-INC SMLREEL
-INC SMLENTI
-INC SMEVOLL
-INC SMLMOTS
-INC CCASSIS
-INC TMVALUE
      INTEGER IPO1
      INTEGER IOPERA
      INTEGER IARGU
      INTEGER I1
      REAL *8 X1
      INTEGER IPO2
      INTEGER IRET
      INTEGER NT1
 
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
*      write(6,*) 'Entree ds opche1',IPO1,IOPERA,IARGU,I1,X1,IPO2,IRET
 
 
      IRET  = 0
      MCHELM= 0
      MCHEL2= 0
      MELVA2= 0
      MLREE2= 0
      MLENT2= 0
      NN0   = 0
      NN1   = 0
      N1PTEL= 0
      N1PT0 = 0
      N1PT1 = 0
 
      N1EL  = 0
      N1EL0 = 0
      N1EL1 = 0
      NT1   = 0
 
      NN2   = 0
      N2PTEL= 0
      N2EL  = 0
      N2EL0 = 0
      N2EL1 = 0
      N2PT0 = 0
      N2PT1 = 0
 
C======================================================================C
C     Activation des SEGMENTS pour placer les MELVAL dans le SVALUE
C======================================================================C
      MCHEL1=IPO1
 
C      IF ((IOPERA .EQ. 3) .OR. (IOPERA .EQ. 4)) THEN
CC       Pour les operations + - on n'accepte que les MCHAML a 1
CC       seule composante.
CC       Pour les fonctions, on traite toutes les composantes en présence
C        CALL EXTR17(IPO1,MLMOTS)
C        SEGACT,MLMOTS
C        JGM=MLMOTS.MOTS(/2)
C        IF(JGM .GT. 1)THEN
C          CALL ERREUR(320)
C          RETURN
C        ENDIF
C      ENDIF
 
      N1   = MCHEL1.ICHAML(/1)
 
      IF (N1 .EQ. 0)THEN
C       Cas du MCHELM vide
        N3=0
        L1=8
        SEGINI,MCHELM
        TITCHE='        '
        IFOCHE=IFOMOD
        IPO2 = MCHELM
        IRET = 1
        RETURN
      ENDIF
 
C     Ajout lecture second argument pour ATAN2 au lieu de ATAN
      IF (IPO2 .GT. 0) THEN
        MCHEL2=IPO2
        N12=MCHEL2.ICHAML(/1)
C       Les deux objets doivent etre de meme taille
        IF (N1 .NE. N12 ) THEN
          CALL ERREUR(329)
          RETURN
        ENDIF
 
        DO I=1,N1
          IF (MCHEL1.IMACHE(I).NE.MCHEL2.IMACHE(I)) THEN
            CALL ERREUR(329)
            RETURN
          ENDIF
        ENDDO
      ENDIF
 
C     Regalge fait sur PC40 pour determiner le nombre de NOEUDS optimum
C     par thread
      IOPTIM = 100
 
      NBPOIN=0
      IPOS1 =0
 
C     Decompte simplement du nombre de TABLEAUX a placer dans le SEGMENT SVALUE
      DO IA=1,N1
        MCHAM1 = MCHEL1.ICHAML(IA)
        N2 = MCHAM1.IELVAL(/1)
        DO IB=1,N2
          MELVA1 = MCHAM1.IELVAL(IB)
          N2PT0  = MELVA1.IELCHE(/1)
          N2EL0  = MELVA1.IELCHE(/2)
          IF    (N2PT0 .EQ. 0 .AND. N2EL0.EQ. 0) THEN
C           Cas des 'REAL*8'
            NBPOIN = NBPOIN + 1
          ELSEIF(MCHAM1.TYPCHE(IB) .EQ. 'POINTEURLISTREEL' .OR.
     &           MCHAM1.TYPCHE(IB) .EQ. 'POINTEURLISTENTI'     ) THEN
            NBPOIN = NBPOIN + (N2PT0*N2EL0)
          ELSEIF(MCHAM1.TYPCHE(IB) .EQ. 'POINTEUREVOLUTIO'     ) THEN
            DO IEL=1,N2EL0
              DO IPEL=1,N2PT0
                MEVOL1=MELVA1.IELCHE(IPEL,IEL)
                N=MEVOL1.IEVOLL(/1)
                NBPOIN = NBPOIN + N
              ENDDO
            ENDDO
          ELSE
            MOTERR(1:16 ) = MCHAM1.TYPCHE(IB)
            MOTERR(17:20) = MCHAM1.NOMCHE(IB)
            MOTERR(21:36) = 'argument       '
            CALL ERREUR(552)
            RETURN
          ENDIF
        ENDDO
      ENDDO
 
      CALL oooprl(1)
      SEGINI,SVALUE
 
      N3   = MCHEL1.INFCHE(/2)
      L1   = MCHEL1.TITCHE(/1)
      SEGINI,MCHELM
      IPO2=MCHELM
      DO 40 IA=1,N1
        MCHAM1=MCHEL1.ICHAML(IA)
        N2    =MCHAM1.IELVAL(/1)
        SEGINI,MCHAML
        MCHELM.ICHAML(IA)=MCHAML
 
C       Verif du meme nombre de composante si second argument
        IF(MCHEL2 .GT. 0) THEN
          MCHAM2 = MCHEL2.ICHAML(IA)
          IF(MCHAM2.IELVAL(/1).NE. N2) THEN
            CALL ERREUR(488)
            RETURN
          ENDIF
        ENDIF
 
C       Travail sur les COMPOSANTES
        DO J = 1,N2        
          MCHAML.NOMCHE(J)=MCHAM1.NOMCHE(J)
          MCHAML.TYPCHE(J)=MCHAM1.TYPCHE(J)
 
          MELVA1 = MCHAM1.IELVAL(J)
          N1PT0  = MELVA1.VELCHE(/1)
          N1EL0  = MELVA1.VELCHE(/2)
          N2PT0  = MELVA1.IELCHE(/1)
          N2EL0  = MELVA1.IELCHE(/2)
 
          NN0    = MAX(N1PT0*N1EL0,N2PT0*N2EL0)
 
C         On a donne 2 arguments, des verifications supplementaires sont necessaires
          IF(MCHEL2 .GT. 0) THEN
C         Verification du Type
            IF (MCHAM2.TYPCHE(J) .NE. 'REAL*8') THEN
C             Le type %m1:16 de la composante %m17:20 du champ par
C             element %m21:36 ne correspond pas a celui attendu
              MOTERR(1:16 ) = MCHAM2.TYPCHE(J)
              MOTERR(17:20) = MCHAM2.NOMCHE(J)
              MOTERR(21:36) = 'argument       '
              CALL ERREUR(552)
              RETURN
            ENDIF
 
C           Verification des composantes
            IF(MCHAML.NOMCHE(J) .NE. MCHAM2.NOMCHE(J)) THEN
              CALL ERREUR(488)
              RETURN
            ENDIF
 
            MELVA2 = MCHAM2.IELVAL(J)
            N1PT1  = MELVA2.VELCHE(/1)
            N1EL1  = MELVA2.VELCHE(/2)
            N2PT1  = MELVA2.IELCHE(/1)
            N2EL1  = MELVA2.IELCHE(/2)
            NN1    = MAX(N1PT1*N1EL1,N2PT1*N2EL1)
          ENDIF
 
          NN2    = MAX(NN0  ,NN1  )
          N1PTEL = MAX(N1PT0,N1PT1)
          N1EL   = MAX(N1EL0,N1EL1)
          N2PTEL = MAX(N2PT0,N2PT1)
          N2EL   = MAX(N2EL0,N2EL1)
          SEGINI,MELVAL
          MCHAML.IELVAL(J) = MELVAL
 
          IF    (MCHAML.TYPCHE(J) .EQ. 'REAL*8'          ) THEN
            IPOS1  = IPOS1 + 1
            SVALUE.ITYPOI (IPOS1  )= 2
            SVALUE.IPOI0  (IPOS1,1)= MELVA1
            SVALUE.IPOI1  (IPOS1,1)= MELVA2
            SVALUE.IPOI2  (IPOS1,1)= MELVAL
            SVALUE.IPOI0  (IPOS1,2)= NN0
            SVALUE.IPOI1  (IPOS1,2)= NN1
            SVALUE.IPOI2  (IPOS1,2)= NN2
            IF (IPOS1 .EQ. 1) THEN
              NT1 = NN2 / IOPTIM
            ELSE
              NT1 = MAX(NT1, NN2/IOPTIM)
            ENDIF
 
          ELSEIF(MCHAML.TYPCHE(J) .EQ. 'POINTEURLISTREEL') THEN
            MLREE2 = 0
            DO IEL=1,N2EL0
              DO IPEL=1,N2PT0
                MLREE1 = MELVA1.IELCHE(IPEL,IEL)
                JG = MLREE1.PROG(/1)
                SEGINI,MLREEL
                MELVAL.IELCHE(IPEL,IEL) = MLREEL
 
                IPOS1  = IPOS1 + 1
                SVALUE.ITYPOI (IPOS1  )= 3
                SVALUE.IPOI0  (IPOS1,1)= MLREE1
                SVALUE.IPOI1  (IPOS1,1)= MLREE2
                SVALUE.IPOI2  (IPOS1,1)= MLREEL
                SVALUE.IPOI0  (IPOS1,2)= JG
                SVALUE.IPOI1  (IPOS1,2)= JG
                SVALUE.IPOI2  (IPOS1,2)= JG
                IF (IPOS1 .EQ. 1) THEN
                  NT1 = JG / IOPTIM
                ELSE
                  NT1 = MAX(NT1, JG/IOPTIM)
                ENDIF
              ENDDO
            ENDDO
 
          ELSEIF(MCHAML.TYPCHE(J) .EQ. 'POINTEURLISTENTI') THEN
            MLENT2 = 0
            DO IEL=1,N2EL0
              DO IPEL=1,N2PT0
                MLENT1 = MELVA1.IELCHE(IPEL,IEL)
                JG = MLENT1.LECT(/1)
                SEGINI,MLENTI
                MELVAL.IELCHE(IPEL,IEL) = MLENTI
 
                IPOS1  = IPOS1 + 1
                SVALUE.ITYPOI (IPOS1  )= 4
                SVALUE.IPOI0  (IPOS1,1)= MLENT1
                SVALUE.IPOI1  (IPOS1,1)= MLENT2
                SVALUE.IPOI2  (IPOS1,1)= MLENTI
                SVALUE.IPOI0  (IPOS1,2)= JG
                SVALUE.IPOI1  (IPOS1,2)= JG
                SVALUE.IPOI2  (IPOS1,2)= JG
                IF (IPOS1 .EQ. 1) THEN
                  NT1 = JG / IOPTIM
                ELSE
                  NT1 = MAX(NT1, JG/IOPTIM)
                ENDIF
              ENDDO
            ENDDO
 
          ELSEIF(MCHAML.TYPCHE(J) .EQ. 'POINTEUREVOLUTIO') THEN
            MLREE2 = 0
            MLENT2 = 0
            DO IEL=1,N2EL0
              DO IPEL=1,N2PT0
                MEVOL1 = MELVA1.IELCHE(IPEL,IEL)
                SEGINI,MEVOLL=MEVOL1
                MELVAL.IELCHE(IPEL,IEL)=MEVOLL
                N=MEVOLL.IEVOLL(/1)
                DO IEV1=1,N
                  KEVOL1 = MEVOLL.IEVOLL(IEV1)
                  SEGINI,KEVOLL=KEVOL1
                  MEVOLL.IEVOLL(IEV1)=KEVOLL
                  IF     (KEVOLL.TYPY .EQ. 'LISTREEL') THEN
                    MLREE1 = KEVOLL.IPROGY
                    JG = MLREE1.PROG(/1)
                    SEGINI,MLREEL
                    KEVOLL.IPROGY = MLREEL
 
                    IPOS1  = IPOS1 + 1
                    SVALUE.ITYPOI (IPOS1  )= 3
                    SVALUE.IPOI0  (IPOS1,1)= MLREE1
                    SVALUE.IPOI1  (IPOS1,1)= MLREE2
                    SVALUE.IPOI2  (IPOS1,1)= MLREEL
                    SVALUE.IPOI0  (IPOS1,2)= JG
                    SVALUE.IPOI1  (IPOS1,2)= JG
                    SVALUE.IPOI2  (IPOS1,2)= JG
                    IF (IPOS1 .EQ. 1) THEN
                      NT1 = JG / IOPTIM
                    ELSE
                      NT1 = MAX(NT1, JG/IOPTIM)
                    ENDIF
 
                  ELSEIF (KEVOLL.TYPY .EQ. 'LISTENTI') THEN
                    MLENT1 = KEVOLL.IPROGY
                    JG = MLENT1.LECT(/1)
                    SEGINI,MLENTI
                    KEVOLL.IPROGY = MLENTI
 
                    IPOS1  = IPOS1 + 1
                    SVALUE.ITYPOI (IPOS1  )= 4
                    SVALUE.IPOI0  (IPOS1,1)= MLENT1
                    SVALUE.IPOI1  (IPOS1,1)= MLENT2
                    SVALUE.IPOI2  (IPOS1,1)= MLENTI
                    SVALUE.IPOI0  (IPOS1,2)= JG
                    SVALUE.IPOI1  (IPOS1,2)= JG
                    SVALUE.IPOI2  (IPOS1,2)= JG
                    IF (IPOS1 .EQ. 1) THEN
                      NT1 = JG / IOPTIM
                    ELSE
                      NT1 = MAX(NT1, JG/IOPTIM)
                    ENDIF
 
                  ELSE
                    MOTERR(1:8 )=KEVOLL.TYPY
                    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
                ENDDO
              ENDDO
            ENDDO
 
          ELSE
C           Le type %m1:16 de la composante %m17:20 du champ par
C           element %m21:36 ne correspond pas a celui attendu
            MOTERR(1:16 ) = MCHAML.TYPCHE(J)
            MOTERR(17:20) = MCHAML.NOMCHE(J)
            MOTERR(21:36) = 'argument       '
            CALL ERREUR(552)
            RETURN
          ENDIF
        ENDDO
 
  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
      CALL oooprl(0)
 
      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
 
 
C     Copie des infos manquantes de MCHEL1
C     Unroll pour aller plus vite
      DO ii=1,N1
        MCHELM.CONCHE(ii)=MCHEL1.CONCHE(ii)
      ENDDO
      DO ii=1,N1
        MCHELM.IMACHE(ii)=MCHEL1.IMACHE(ii)
      ENDDO
      DO kk=1,N3
        DO ii=1,N1
          MCHELM.INFCHE(ii,kk)=MCHEL1.INFCHE(ii,kk)
        ENDDO
      ENDDO
      MCHELM.TITCHE=MCHEL1.TITCHE
      MCHELM.IFOCHE=MCHEL1.IFOCHE
      SEGSUP,SVALUE,SPARAL
 
      IRET = 1
      END
 
 
 
 
 
 

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