C OPEVO1 SOURCE OF166741 25/02/20 21:17:16 12165 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