C OPCHE1 SOURCE SP204843 26/04/01 21:15:02 12511 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 SMCOORD -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=6 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