C OPERSO SOURCE FANDEUR 10/12/14 21:18:31 6812 SUBROUTINE OPERSO C_______________________________________________________________________ C C SOUSTRAIT 2 NOMBRES (ENTIER OU FLOTTANT) C 2 CHPS/ELMTS C 2 CHPS/POINT C 2 EVOLUTIONS C 2 LISTES ENTIERES C 2 LISTES REELLES C 2 TABLE SOUSTYPE VECTEUR C C PASSAGE AUX NOUVEAUX MCHAMLS PAR JM CAMPENON LE 29 10 90 C C_______________________________________________________________________ C IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC CCOPTIO -INC SMTABLE CHARACTER*8 ITYP,CHA1,CHA2 * * RECHERCHE DU TYPE DU PREMIER ARGUMENT * CALL QUETYP(ITYP,0,IRETOU) C C CHERCHE A LIROBJ DES CHAMPS PAR ELEMENT (MCHAML) C 101 CALL LIROBJ('MCHAML',IPCHE1,0,IRETOU) IF (IRETOU.EQ.0) GOTO 102 CALL LIROBJ('MCHAML',IPCHE2,0,IRETOU) IF (IRETOU.EQ.0) THEN CALL REFUS GO TO 102 ENDIF CALL ADCHEL(IPCHE1,IPCHE2,IPCHAD,-1) CALL ECROBJ('MCHAML',IPCHAD) RETURN C C CHERCHE A LIROBJ DES CHAMPS PAR POINT C 102 CALL LIROBJ('CHPOINT ',IPO1,0,IRETOU) IF (IRETOU.EQ.0) GOTO 103 CALL LIROBJ('CHPOINT ',IPO2,0,IRETOU) IF (IRETOU.EQ.0) THEN CALL REFUS GO TO 103 ENDIF CALL ADCHPO(IPO1,IPO2,IRET,1D0,-1D0) IF(IRET.EQ.0) RETURN CALL ECROBJ('CHPOINT ',IRET) RETURN C C SOUSTRACTION CHPOINT-FLOTTANT OU FLOTTANT-CHPOINT 103 CALL LIROBJ('CHPOINT ',IPO1,0,IRETOU) IF (IRETOU.EQ.0) GOTO 104 IAD=1 IF(ITYP.NE.'CHPOINT ') IAD= -1 CALL LIRREE(X1,0,IRETOU) IF (IRETOU.EQ.0) THEN CALL REFUS GO TO 104 ENDIF X1=-X1 CALL ADCHPF(IPO1,X1,IRET,IAD) IF(IRET.EQ.0) RETURN CALL ECROBJ('CHPOINT ',IRET) RETURN C C CHERCHE A LIROBJ DES EVOLUTIONS C 104 CALL LIROBJ('EVOLUTIO',IPO1,0,IRETOU) IF(IRETOU.EQ.0) GOTO 105 CALL LIROBJ('EVOLUTIO',IPO2,0,IRETOU) IF (IRETOU.EQ.0) THEN CALL REFUS GO TO 105 ENDIF CALL ADEVOL(IPO1,IPO2,IRET,-1) IF(IRET.EQ.0) RETURN CALL ECROBJ('EVOLUTIO',IRET) RETURN C C CHERCHE A LIROBJ DES LISTES REELLES C 105 CALL LIROBJ('LISTREEL',IPO1,0,IRETOU) IF(IRETOU.EQ.0) GOTO 106 CALL LIROBJ('LISTREEL',IPO2,0,IRETOU) IF (IRETOU.EQ.0) THEN CALL REFUS GO TO 106 ENDIF CALL ADLISR(IPO1,IPO2,IRET,-1) IF(IRET.EQ.0) RETURN CALL ECROBJ('LISTREEL',IRET) RETURN C C CHERCHE A LIROBJ DES LISTES ENTIERES C 106 CALL LIROBJ('LISTENTI',IPO1,0,IRETOU) IF(IRETOU.EQ.0) GOTO 107 CALL LIROBJ('LISTENTI',IPO2,0,IRETOU) IF (IRETOU.EQ.0) THEN CALL REFUS GO TO 107 ENDIF CALL ADLISE(IPO1,IPO2,IRET,-1) IF(IRET.EQ.0) RETURN CALL ECROBJ('LISTENTI',IRET) RETURN C C CHERCHE A LIROBJ 2 NOMBRES ENTIER C 107 CALL LIRENT(I1,0,IRETOU) IF (IRETOU.EQ.0) GOTO 108 CALL LIRENT(I2,0,IRETOU) IF (IRETOU.EQ.0) THEN CALL REFUS GO TO 108 ENDIF CALL ECRENT(I1-I2) RETURN C C CHERCHE A LIROBJ 2 NOMBRES FLOTTANTS C 108 CALL LIRREE(X1,0,IRETOU) IF (IRETOU.EQ.0) GOTO 109 CALL LIRREE(X2,0,IRETOU) IF (IRETOU.EQ.0) THEN CALL REFUS GO TO 109 ENDIF CALL ECRREE(X1-X2) RETURN C C CHERCHE A LIROBJ 2 TABLES SOUS-TYPE VECTEUR C 109 CALL LIRTAB('VECTEUR',MTAB1,0,IRETOU) IF (IRETOU.EQ.0) GOTO 110 CALL QUENOM(MOTERR(1:8)) CALL LIRTAB('VECTEUR',MTAB2,0,IRETOU) IF (IRETOU.EQ.0) THEN CALL REFUS GO TO 110 ENDIF CALL QUENOM(MOTERR(9:16)) SEGINI,MTABLE=MTAB1 SEGACT MTAB2 DO 71 J=1,MTAB2.MLOTAB CHA1=MTAB2.MTABTI(J) X1=MTAB2.RMTABI(J) IVA1=MTAB2.MTABII(J) DO 72 I=1,MLOTAB IF (CHA1.NE.MTABTI(I)) GOTO 72 IF (CHA1.EQ.'FLOTTANT') THEN IF (X1.NE.RMTABI(I)) GOTO 72 ELSE IF (IVA1.NE.MTABII(I)) GOTO 72 ENDIF * ON A UN INDICE COMMUN ON REGARDE SI LE TYPE DE LA DONNEE EST SOMMABLE CHA2=MTAB2.MTABTV(J) IF (CHA2.EQ.'FLOTTANT') THEN IF (MTABTV(I).EQ.'FLOTTANT') THEN RMTABV(I)=RMTABV(I)-MTAB2.RMTABV(J) ELSEIF (MTABTV(I).EQ.'ENTIER ') THEN MTABTV(I)='FLOTTANT' RMTABV(I)=MTABIV(I)-MTAB2.RMTABV(J) ELSE CALL ERREUR(135) ENDIF ELSEIF (CHA2.EQ.'ENTIER ') THEN IF (MTABTV(I).EQ.'ENTIER ') THEN MTABIV(I)=MTABIV(I)-MTAB2.MTABIV(J) ELSEIF (MTABTV(I).EQ.'FLOTTANT') THEN RMTABV(I)=RMTABV(I)-MTAB2.MTABIV(J) ELSE CALL ERREUR(135) ENDIF ELSE IF (MTABTV(I).NE.CHA2.OR.MTABTV(I).NE.MTAB2.MTABTV(J)) # CALL ERREUR(135) ENDIF * C'EST PASSE OU CA A CASSE ON SORT IF (IERR.NE.0) RETURN GOTO 71 72 CONTINUE * ON RAJOUTE LE MTAB2(J) A MTABL MLOTAB=MLOTAB+1 M=MTABII(/1) IF (M.LT.MLOTAB) THEN M=M+100 SEGADJ MTABLE ENDIF MTABII(MLOTAB)=MTAB2.MTABII(J) MTABTI(MLOTAB)=MTAB2.MTABTI(J) RMTABI(MLOTAB)=MTAB2.RMTABI(J) MTABIV(MLOTAB)=MTAB2.MTABIV(J) MTABTV(MLOTAB)=MTAB2.MTABTV(J) RMTABV(MLOTAB)=-MTAB2.RMTABV(J) * SI ENTIER ON OPPOSE IF (MTABTV(MLOTAB).EQ.'ENTIER ') MTABIV(MLOTAB)=-MTABIV(MLOTAB) 71 CONTINUE SEGDES MTABLE,MTAB1,MTAB2 CALL ECROBJ('TABLE',MTABLE) RETURN C C ON A DONC RIEN TROUVE POUR FAIRE L OPERATION C 110 CONTINUE CALL QUETYP(MOTERR(1:8),0,IRETOU) IF(IRETOU.NE.0) THEN CALL LIROBJ(MOTERR(1:8),IRET,1,IRETOU) CALL QUETYP(MOTERR(9:16),0,IRETOU) IF (IRETOU.EQ.0) MOTERR(9:16) = ' ???? ' CALL ERREUR(532) ELSE CALL ERREUR(533) ENDIF RETURN END