C OPERAD SOURCE FANDEUR 10/12/14 21:18:21 6812 SUBROUTINE OPERAD C_______________________________________________________________________ C C ADDITIONNE 2 NOMBRES (ENTIER OU FLOTTANT) C 2 CHPS/ELMTS C 2 CHPS/POINT C 2 EVOLUTIONS C 2 LISTES REELLES C 2 LISTES ENTIERES C 2 TABLES SOUS-TYPE 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) C -INC CCOPTIO -INC SMTABLE C logical ir1 CHARACTER*8 CHA1,CHA2,CTYP C C CHERCHE A LIRE DES CHAMPS PAR ELEMENT C 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) IF (IPCHAD.EQ.0) RETURN CALL ECROBJ('MCHAML',IPCHAD) RETURN C C CHERCHE A LIRE 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 CHERCHE A LIRE UN CHAMP PAR POINT ET UN FLOTTANT C 103 CALL LIROBJ('CHPOINT ',IPO1,0,IRETOU) IF (IRETOU.EQ.0) GOTO 104 CALL LIRREE(X1,0,IRETOU) IF (IRETOU.EQ.0) THEN CALL REFUS GO TO 104 ENDIF CALL ADCHPF(IPO1,X1,IRET,1) 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 LIRE 2 NOMBRES ENTIERS 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 LIRE 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) GO TO 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) 71 CONTINUE SEGDES MTABLE,MTAB1,MTAB2 CALL ECROBJ('TABLE',MTABLE) RETURN C C Est ce une table esclave de chamelem C 110 CONTINUE CALL LIRTAB('ESCLAVE',MTABle,0,IRETOU) if (iretou.eq.0) goto 120 segact mtable ml=mlotab * l'indice 1 est le sous type ind=mtabii(2) ctyp=' ' call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0, > CTYP,id3,rr1,' ',ir1,id1) iretou=id1 if (CTYP.eq.'MCHAML') then do i=3,ml segact mtable ind=mtabii(i) call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0, > CTYP,id3,rr1,' ',ir1,id2) if (ierr.ne.0) return call ADCHEL(ID1,ID2,IRETOU,1) id1=iretou enddo segdes mtable goto 100 elseif (CTYP.eq.'CHPOINT ') then do i=3,ml segact mtable ind=mtabii(i) call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0, > CTYP,id3,rr1,' ',ir1,id2) if (ierr.ne.0) return call ADCHPO(ID1,ID2,IRETOU,1D0,1D0) id1=iretou enddo segdes mtable goto 100 else moterr(1:8)='MCHAML ' call erreur(-173) call erreur(648) return endif 100 continue if (ierr.ne.0) return call ecrobj(ctyp,iretou) return C C ON A DONC RIEN TROUVE POUR FAIRE L OPERATION C 120 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