1 : C OPERAD SOURCE FANDEUR 10/12/14 21:18:21 6812 2 : SUBROUTINE OPERAD 3 : C_______________________________________________________________________ 4 : C 5 : C ADDITIONNE 2 NOMBRES (ENTIER OU FLOTTANT) 6 : C 2 CHPS/ELMTS 7 : C 2 CHPS/POINT 8 : C 2 EVOLUTIONS 9 : C 2 LISTES REELLES 10 : C 2 LISTES ENTIERES 11 : C 2 TABLES SOUS-TYPE 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 : C 20 : -INC CCOPTIO 21 : -INC SMTABLE 22 : C 23 : logical ir1 24 : CHARACTER*8 CHA1,CHA2,CTYP 25 : C 26 : C CHERCHE A LIRE DES CHAMPS PAR ELEMENT 27 : C 27 : 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) 32 : IF (IPCHAD.EQ.0) RETURN 32 : CALL ECROBJ('MCHAML',IPCHAD) 33 : RETURN 34 : C 35 : C CHERCHE A LIRE DES CHAMPS PAR POINT 36 : C 36 : 102 CALL LIROBJ('CHPOINT ',IPO1,0,IRETOU) 37 : IF (IRETOU.EQ.0) GOTO 103 37 : CALL LIROBJ('CHPOINT ',IPO2,0,IRETOU) 38 : IF(IRETOU.EQ.0) THEN 38 : CALL REFUS 39 : GO TO 103 40 : ENDIF 40 : CALL ADCHPO(IPO1,IPO2,IRET,1D0,1D0) 41 : IF(IRET.EQ.0) RETURN 41 : CALL ECROBJ('CHPOINT ',IRET) 42 : RETURN 43 : C 44 : C CHERCHE A LIRE UN CHAMP PAR POINT ET UN FLOTTANT 45 : C 45 : 103 CALL LIROBJ('CHPOINT ',IPO1,0,IRETOU) 46 : IF (IRETOU.EQ.0) GOTO 104 46 : CALL LIRREE(X1,0,IRETOU) 47 : IF (IRETOU.EQ.0) THEN 47 : CALL REFUS 48 : GO TO 104 49 : ENDIF 49 : CALL ADCHPF(IPO1,X1,IRET,1) 50 : IF(IRET.EQ.0) RETURN 50 : CALL ECROBJ('CHPOINT ',IRET) 51 : RETURN 52 : C 53 : C CHERCHE A LIROBJ DES EVOLUTIONS 54 : C 54 : 104 CALL LIROBJ('EVOLUTIO',IPO1,0,IRETOU) 55 : IF(IRETOU.EQ.0) GOTO 105 55 : CALL LIROBJ('EVOLUTIO',IPO2,0,IRETOU) 56 : IF(IRETOU.EQ.0) THEN 56 : CALL REFUS 57 : GO TO 105 58 : ENDIF 58 : CALL ADEVOL(IPO1,IPO2,IRET,1) 59 : IF(IRET.EQ.0) RETURN 59 : CALL ECROBJ('EVOLUTIO',IRET) 60 : RETURN 61 : C 62 : C CHERCHE A LIROBJ DES LISTES REELLES 63 : C 63 : 105 CALL LIROBJ('LISTREEL',IPO1,0,IRETOU) 64 : IF(IRETOU.EQ.0) GOTO 106 64 : CALL LIROBJ('LISTREEL',IPO2,0,IRETOU) 65 : IF(IRETOU.EQ.0) THEN 65 : CALL REFUS 66 : GO TO 106 67 : ENDIF 67 : CALL ADLISR(IPO1,IPO2,IRET,1) 68 : IF(IRET.EQ.0) RETURN 68 : CALL ECROBJ('LISTREEL',IRET) 69 : RETURN 70 : C 71 : C CHERCHE A LIROBJ DES LISTES ENTIERES 72 : C 72 : 106 CALL LIROBJ('LISTENTI',IPO1,0,IRETOU) 73 : IF(IRETOU.EQ.0) GOTO 107 73 : CALL LIROBJ('LISTENTI',IPO2,0,IRETOU) 74 : IF(IRETOU.EQ.0) THEN 74 : CALL REFUS 75 : GO TO 107 76 : ENDIF 76 : CALL ADLISE(IPO1,IPO2,IRET,1) 77 : IF(IRET.EQ.0) RETURN 77 : CALL ECROBJ('LISTENTI',IRET) 78 : RETURN 79 : C 80 : C CHERCHE A LIRE 2 NOMBRES ENTIERS 81 : C 81 : 107 CALL LIRENT(I1,0,IRETOU) 82 : IF (IRETOU.EQ.0) GOTO 108 82 : CALL LIRENT(I2,0,IRETOU) 83 : IF (IRETOU.EQ.0) THEN 83 : CALL REFUS 84 : GO TO 108 85 : ENDIF 85 : CALL ECRENT(I1+I2) 86 : RETURN 87 : C 88 : C CHERCHE A LIRE 2 NOMBRES FLOTTANTS 89 : C 89 : 108 CALL LIRREE(X1,0,IRETOU) 90 : IF (IRETOU.EQ.0) GOTO 109 90 : CALL LIRREE(X2,0,IRETOU) 91 : IF (IRETOU.EQ.0) THEN 91 : CALL REFUS 92 : GO TO 109 93 : ENDIF 93 : CALL ECRREE(X1+X2) 94 : RETURN 95 : C 96 : C CHERCHE A LIROBJ 2 TABLES SOUS-TYPE VECTEUR 97 : C 97 : 109 CALL LIRTAB('VECTEUR',MTAB1,0,IRETOU) 98 : IF(IRETOU.EQ.0) GO TO 110 98 : CALL QUENOM(MOTERR(1:8)) 98 : CALL LIRTAB('VECTEUR',MTAB2,0,IRETOU) 99 : IF (IRETOU.EQ.0) THEN 99 : CALL REFUS 100 : GO TO 110 101 : ENDIF 101 : CALL QUENOM(MOTERR(9:16)) 102 : SEGINI,MTABLE=MTAB1 103 : SEGACT MTAB2 104 : DO 71 J=1,MTAB2.MLOTAB 105 : CHA1=MTAB2.MTABTI(J) 106 : X1=MTAB2.RMTABI(J) 107 : IVA1=MTAB2.MTABII(J) 108 : DO 72 I=1,MLOTAB 109 : IF (CHA1.NE.MTABTI(I)) GOTO 72 110 : IF (CHA1.EQ.'FLOTTANT') THEN 111 : IF (X1.NE.RMTABI(I)) GOTO 72 112 : ELSE 113 : IF (IVA1.NE.MTABII(I)) GOTO 72 114 : ENDIF 115 : * ON A UN INDICE COMMUN ON REGARDE SI LE TYPE DE LA DONNEE EST SOMMABLE 116 : CHA2=MTAB2.MTABTV(J) 117 : IF (CHA2.EQ.'FLOTTANT') THEN 118 : IF (MTABTV(I).EQ.'FLOTTANT') THEN 119 : RMTABV(I)=RMTABV(I)+MTAB2.RMTABV(J) 120 : ELSEIF (MTABTV(I).EQ.'ENTIER ') THEN 121 : MTABTV(I)='FLOTTANT' 122 : RMTABV(I)=MTABIV(I)+MTAB2.RMTABV(J) 123 : ELSE 123 : CALL ERREUR(135) 124 : ENDIF 125 : ELSEIF (CHA2.EQ.'ENTIER ') THEN 126 : IF (MTABTV(I).EQ.'ENTIER ') THEN 127 : MTABIV(I)=MTABIV(I)+MTAB2.MTABIV(J) 128 : ELSEIF (MTABTV(I).EQ.'FLOTTANT') THEN 129 : RMTABV(I)=RMTABV(I)+MTAB2.MTABIV(J) 130 : ELSE 130 : CALL ERREUR(135) 131 : ENDIF 132 : ELSE 133 : IF (MTABTV(I).NE.CHA2.OR.MTABTV(I).NE.MTAB2.MTABTV(J)) 133 : # CALL ERREUR(135) 134 : ENDIF 135 : * C'EST PASSE OU CA A CASSE ON SORT 136 : IF (IERR.NE.0) RETURN 137 : GOTO 71 138 : 72 CONTINUE 139 : * ON RAJOUTE LE MTAB2(J) A MTABL 140 : MLOTAB=MLOTAB+1 141 : M=MTABII(/1) 142 : IF (M.LT.MLOTAB) THEN 143 : M=M+100 144 : SEGADJ MTABLE 145 : ENDIF 146 : MTABII(MLOTAB)=MTAB2.MTABII(J) 147 : MTABTI(MLOTAB)=MTAB2.MTABTI(J) 148 : RMTABI(MLOTAB)=MTAB2.RMTABI(J) 149 : MTABIV(MLOTAB)=MTAB2.MTABIV(J) 150 : MTABTV(MLOTAB)=MTAB2.MTABTV(J) 151 : RMTABV(MLOTAB)=MTAB2.RMTABV(J) 152 : 71 CONTINUE 153 : SEGDES MTABLE,MTAB1,MTAB2 153 : CALL ECROBJ('TABLE',MTABLE) 154 : RETURN 155 : C 156 : C Est ce une table esclave de chamelem 157 : C 158 : 110 CONTINUE 158 : CALL LIRTAB('ESCLAVE',MTABle,0,IRETOU) 159 : if (iretou.eq.0) goto 120 160 : segact mtable 161 : ml=mlotab 162 : * l'indice 1 est le sous type 163 : ind=mtabii(2) 164 : ctyp=' ' 164 : call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0, 165 : > CTYP,id3,rr1,' ',ir1,id1) 166 : iretou=id1 167 : if (CTYP.eq.'MCHAML') then 168 : do i=3,ml 169 : segact mtable 170 : ind=mtabii(i) 170 : call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0, 171 : > CTYP,id3,rr1,' ',ir1,id2) 172 : if (ierr.ne.0) return 172 : call ADCHEL(ID1,ID2,IRETOU,1) 173 : id1=iretou 174 : enddo 175 : segdes mtable 176 : goto 100 177 : elseif (CTYP.eq.'CHPOINT ') then 178 : do i=3,ml 179 : segact mtable 180 : ind=mtabii(i) 180 : call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0, 181 : > CTYP,id3,rr1,' ',ir1,id2) 182 : if (ierr.ne.0) return 182 : call ADCHPO(ID1,ID2,IRETOU,1D0,1D0) 183 : id1=iretou 184 : enddo 185 : segdes mtable 186 : goto 100 187 : else 188 : moterr(1:8)='MCHAML ' 188 : call erreur(-173) 188 : call erreur(648) 189 : return 190 : endif 191 : 100 continue 192 : if (ierr.ne.0) return 192 : call ecrobj(ctyp,iretou) 193 : return 194 : C 195 : C ON A DONC RIEN TROUVE POUR FAIRE L OPERATION 196 : C 197 : 120 CONTINUE 197 : CALL QUETYP(MOTERR(1:8),0,IRETOU) 198 : IF(IRETOU.NE.0) THEN 198 : CALL LIROBJ(MOTERR(1:8),IRET,1,IRETOU) 198 : CALL QUETYP(MOTERR(9:16),0,IRETOU) 199 : IF (IRETOU.EQ.0) MOTERR(9:16) = ' ???? ' 199 : CALL ERREUR(532) 200 : ELSE 200 : CALL ERREUR(533) 201 : ENDIF 202 : RETURN 203 : END 204 : 205 :
© Cast3M 2003 - All rights reserved.
Disclaimer