1 : C OPERSO SOURCE FANDEUR 10/12/14 21:18:31 6812 2 : SUBROUTINE OPERSO 3 : C_______________________________________________________________________ 4 : C 5 : C SOUSTRAIT 2 NOMBRES (ENTIER OU FLOTTANT) 6 : C 2 CHPS/ELMTS 7 : C 2 CHPS/POINT 8 : C 2 EVOLUTIONS 9 : C 2 LISTES ENTIERES 10 : C 2 LISTES REELLES 11 : C 2 TABLE SOUSTYPE VECTEUR 12 : C 13 : C PASSAGE AUX NOUVEAUX MCHAMLS PAR JM CAMPENON LE 29 10 90 14 : C 15 : C_______________________________________________________________________ 16 : C 17 : IMPLICIT INTEGER(I-N) 18 : IMPLICIT REAL*8(A-H,O-Z) 19 : -INC CCOPTIO 20 : -INC SMTABLE 21 : CHARACTER*8 ITYP,CHA1,CHA2 22 : * 23 : * RECHERCHE DU TYPE DU PREMIER ARGUMENT 24 : * 24 : CALL QUETYP(ITYP,0,IRETOU) 25 : C 26 : C CHERCHE A LIROBJ DES CHAMPS PAR ELEMENT (MCHAML) 27 : C 27 : 101 CALL LIROBJ('MCHAML',IPCHE1,0,IRETOU) 28 : IF (IRETOU.EQ.0) GOTO 102 28 : CALL LIROBJ('MCHAML',IPCHE2,0,IRETOU) 29 : IF (IRETOU.EQ.0) THEN 29 : CALL REFUS 30 : GO TO 102 31 : ENDIF 31 : CALL ADCHEL(IPCHE1,IPCHE2,IPCHAD,-1) 31 : CALL ECROBJ('MCHAML',IPCHAD) 32 : RETURN 33 : C 34 : C CHERCHE A LIROBJ DES CHAMPS PAR POINT 35 : C 35 : 102 CALL LIROBJ('CHPOINT ',IPO1,0,IRETOU) 36 : IF (IRETOU.EQ.0) GOTO 103 36 : CALL LIROBJ('CHPOINT ',IPO2,0,IRETOU) 37 : IF (IRETOU.EQ.0) THEN 37 : CALL REFUS 38 : GO TO 103 39 : ENDIF 39 : CALL ADCHPO(IPO1,IPO2,IRET,1D0,-1D0) 40 : IF(IRET.EQ.0) RETURN 40 : CALL ECROBJ('CHPOINT ',IRET) 41 : RETURN 42 : C 43 : C SOUSTRACTION CHPOINT-FLOTTANT OU FLOTTANT-CHPOINT 44 : 44 : 103 CALL LIROBJ('CHPOINT ',IPO1,0,IRETOU) 45 : IF (IRETOU.EQ.0) GOTO 104 46 : IAD=1 47 : IF(ITYP.NE.'CHPOINT ') IAD= -1 47 : CALL LIRREE(X1,0,IRETOU) 48 : IF (IRETOU.EQ.0) THEN 48 : CALL REFUS 49 : GO TO 104 50 : ENDIF 51 : X1=-X1 51 : CALL ADCHPF(IPO1,X1,IRET,IAD) 52 : IF(IRET.EQ.0) RETURN 52 : CALL ECROBJ('CHPOINT ',IRET) 53 : RETURN 54 : C 55 : C CHERCHE A LIROBJ DES EVOLUTIONS 56 : C 56 : 104 CALL LIROBJ('EVOLUTIO',IPO1,0,IRETOU) 57 : IF(IRETOU.EQ.0) GOTO 105 57 : CALL LIROBJ('EVOLUTIO',IPO2,0,IRETOU) 58 : IF (IRETOU.EQ.0) THEN 58 : CALL REFUS 59 : GO TO 105 60 : ENDIF 60 : CALL ADEVOL(IPO1,IPO2,IRET,-1) 61 : IF(IRET.EQ.0) RETURN 61 : CALL ECROBJ('EVOLUTIO',IRET) 62 : RETURN 63 : C 64 : C CHERCHE A LIROBJ DES LISTES REELLES 65 : C 65 : 105 CALL LIROBJ('LISTREEL',IPO1,0,IRETOU) 66 : IF(IRETOU.EQ.0) GOTO 106 66 : CALL LIROBJ('LISTREEL',IPO2,0,IRETOU) 67 : IF (IRETOU.EQ.0) THEN 67 : CALL REFUS 68 : GO TO 106 69 : ENDIF 69 : CALL ADLISR(IPO1,IPO2,IRET,-1) 70 : IF(IRET.EQ.0) RETURN 70 : CALL ECROBJ('LISTREEL',IRET) 71 : RETURN 72 : C 73 : C CHERCHE A LIROBJ DES LISTES ENTIERES 74 : C 74 : 106 CALL LIROBJ('LISTENTI',IPO1,0,IRETOU) 75 : IF(IRETOU.EQ.0) GOTO 107 75 : CALL LIROBJ('LISTENTI',IPO2,0,IRETOU) 76 : IF (IRETOU.EQ.0) THEN 76 : CALL REFUS 77 : GO TO 107 78 : ENDIF 78 : CALL ADLISE(IPO1,IPO2,IRET,-1) 79 : IF(IRET.EQ.0) RETURN 79 : CALL ECROBJ('LISTENTI',IRET) 80 : RETURN 81 : C 82 : C CHERCHE A LIROBJ 2 NOMBRES ENTIER 83 : C 83 : 107 CALL LIRENT(I1,0,IRETOU) 84 : IF (IRETOU.EQ.0) GOTO 108 84 : CALL LIRENT(I2,0,IRETOU) 85 : IF (IRETOU.EQ.0) THEN 85 : CALL REFUS 86 : GO TO 108 87 : ENDIF 87 : CALL ECRENT(I1-I2) 88 : RETURN 89 : C 90 : C CHERCHE A LIROBJ 2 NOMBRES FLOTTANTS 91 : C 91 : 108 CALL LIRREE(X1,0,IRETOU) 92 : IF (IRETOU.EQ.0) GOTO 109 92 : CALL LIRREE(X2,0,IRETOU) 93 : IF (IRETOU.EQ.0) THEN 93 : CALL REFUS 94 : GO TO 109 95 : ENDIF 95 : CALL ECRREE(X1-X2) 96 : RETURN 97 : C 98 : C CHERCHE A LIROBJ 2 TABLES SOUS-TYPE VECTEUR 99 : C 99 : 109 CALL LIRTAB('VECTEUR',MTAB1,0,IRETOU) 100 : IF (IRETOU.EQ.0) GOTO 110 100 : CALL QUENOM(MOTERR(1:8)) 100 : CALL LIRTAB('VECTEUR',MTAB2,0,IRETOU) 101 : IF (IRETOU.EQ.0) THEN 101 : CALL REFUS 102 : GO TO 110 103 : ENDIF 103 : CALL QUENOM(MOTERR(9:16)) 104 : SEGINI,MTABLE=MTAB1 105 : SEGACT MTAB2 106 : DO 71 J=1,MTAB2.MLOTAB 107 : CHA1=MTAB2.MTABTI(J) 108 : X1=MTAB2.RMTABI(J) 109 : IVA1=MTAB2.MTABII(J) 110 : DO 72 I=1,MLOTAB 111 : IF (CHA1.NE.MTABTI(I)) GOTO 72 112 : IF (CHA1.EQ.'FLOTTANT') THEN 113 : IF (X1.NE.RMTABI(I)) GOTO 72 114 : ELSE 115 : IF (IVA1.NE.MTABII(I)) GOTO 72 116 : ENDIF 117 : * ON A UN INDICE COMMUN ON REGARDE SI LE TYPE DE LA DONNEE EST SOMMABLE 118 : CHA2=MTAB2.MTABTV(J) 119 : IF (CHA2.EQ.'FLOTTANT') THEN 120 : IF (MTABTV(I).EQ.'FLOTTANT') THEN 121 : RMTABV(I)=RMTABV(I)-MTAB2.RMTABV(J) 122 : ELSEIF (MTABTV(I).EQ.'ENTIER ') THEN 123 : MTABTV(I)='FLOTTANT' 124 : RMTABV(I)=MTABIV(I)-MTAB2.RMTABV(J) 125 : ELSE 125 : CALL ERREUR(135) 126 : ENDIF 127 : ELSEIF (CHA2.EQ.'ENTIER ') THEN 128 : IF (MTABTV(I).EQ.'ENTIER ') THEN 129 : MTABIV(I)=MTABIV(I)-MTAB2.MTABIV(J) 130 : ELSEIF (MTABTV(I).EQ.'FLOTTANT') THEN 131 : RMTABV(I)=RMTABV(I)-MTAB2.MTABIV(J) 132 : ELSE 132 : CALL ERREUR(135) 133 : ENDIF 134 : ELSE 135 : IF (MTABTV(I).NE.CHA2.OR.MTABTV(I).NE.MTAB2.MTABTV(J)) 135 : # CALL ERREUR(135) 136 : ENDIF 137 : * C'EST PASSE OU CA A CASSE ON SORT 138 : IF (IERR.NE.0) RETURN 139 : GOTO 71 140 : 72 CONTINUE 141 : * ON RAJOUTE LE MTAB2(J) A MTABL 142 : MLOTAB=MLOTAB+1 143 : M=MTABII(/1) 144 : IF (M.LT.MLOTAB) THEN 145 : M=M+100 146 : SEGADJ MTABLE 147 : ENDIF 148 : MTABII(MLOTAB)=MTAB2.MTABII(J) 149 : MTABTI(MLOTAB)=MTAB2.MTABTI(J) 150 : RMTABI(MLOTAB)=MTAB2.RMTABI(J) 151 : MTABIV(MLOTAB)=MTAB2.MTABIV(J) 152 : MTABTV(MLOTAB)=MTAB2.MTABTV(J) 153 : RMTABV(MLOTAB)=-MTAB2.RMTABV(J) 154 : * SI ENTIER ON OPPOSE 155 : IF (MTABTV(MLOTAB).EQ.'ENTIER ') MTABIV(MLOTAB)=-MTABIV(MLOTAB) 156 : 71 CONTINUE 157 : SEGDES MTABLE,MTAB1,MTAB2 157 : CALL ECROBJ('TABLE',MTABLE) 158 : RETURN 159 : C 160 : C ON A DONC RIEN TROUVE POUR FAIRE L OPERATION 161 : C 162 : 110 CONTINUE 162 : CALL QUETYP(MOTERR(1:8),0,IRETOU) 163 : IF(IRETOU.NE.0) THEN 163 : CALL LIROBJ(MOTERR(1:8),IRET,1,IRETOU) 163 : CALL QUETYP(MOTERR(9:16),0,IRETOU) 164 : IF (IRETOU.EQ.0) MOTERR(9:16) = ' ???? ' 164 : CALL ERREUR(532) 165 : ELSE 165 : CALL ERREUR(533) 166 : ENDIF 167 : 168 : RETURN 169 : END 170 : 171 :
© Cast3M 2003 - All rights reserved.
Disclaimer