1 : C COLI SOURCE FANDEUR 10/12/14 21:15:33 6812 2 : SUBROUTINE COLI 3 : *_______________________________________________________________________ 4 : * 5 : * COMBINAISON LINEAIRE DE CHPOINT OU DE MCHAML 6 : * 7 : * 8 : * OPERATEUR COLI : OBJ = | FLOT1*OBJ1 + FLOT2*OBJ2 + ...... | 9 : * | TABLE LISTREEL | 10 : * OPERATION POSSIBLE SUR DES CHPOINTS ET DES CHAMELEMS 11 : * 12 : * PASSAGE AUX NOUVEAUX MCHAMLS PAR JM CAMPENON LE 01/91 13 : * OPERANDES TABLE ET LISTREEL INCORPORES LE 02/98 PAR MO 14 : * LA VERSION DU 02/98 LAISSAIT TROP DE LIBERTE SUR LES INDICES DE 15 : * LA TABLE.ON NE PERMET DORENAVANT QUE DES INDICES DE TYPE ENTIER ALLANT 16 : * DE 1 a N PAR PAS DE 1 03/98 PAR MO 17 : *_______________________________________________________________________ 18 : * 19 : IMPLICIT INTEGER(I-N) 20 : IMPLICIT REAL*8 (A-H,O-Z) 21 : -INC CCOPTIO 22 : -INC SMTABLE 23 : -INC SMLREEL 24 : SEGMENT ITA1(0) 25 : SEGMENT ITAN(0) 26 : * 27 : SEGMENT ITA2 28 : REAL*8 TA2(0) 29 : ENDSEGMENT 30 : * 31 : CHARACTER*(8) ITYPE,ITCHPO,ITCHAM,ITTABL,ITYPIND 32 : REAL*8 RET 33 : DATA ITCHPO/'CHPOINT '/ 34 : DATA ITCHAM/'MCHAML '/ 35 : DATA ITTABL/'TABLE '/ 36 : ICHP=0 37 : * 38 : C CHPOINT: 38 : CALL LIROBJ(ITCHPO,IRET,0,IRETOU) 39 : IF(IRETOU.EQ.0) GOTO 2 40 : ITYPE=ITCHPO 41 : GOTO10 42 : * 43 : C MCHAML: 43 : 2 CALL LIROBJ(ITCHAM,IRET,0,IRETOU) 44 : IF(IRETOU.EQ.0) GOTO 4 45 : ITYPE=ITCHAM 46 : GOTO10 47 : ************************************************ 48 : C TABLE et LISTREEL : 48 : 4 CALL LIROBJ(ITTABL,IRET,0,IRETOU) 49 : IF(IRETOU.EQ.0) GOTO 1 50 : MTABLE=IRET 51 : SEGACT MTABLE 52 : NB=MLOTAB 53 : * la table ne doit contenir que des champs ET doit etre 54 : * indicee par des entiers de 1 a n 55 : IF((MTABTV(1).NE.'CHPOINT ').AND.(MTABTV(1).NE.'MCHAML ')) THEN 56 : MOTERR(1:8)=MTABTV(1) 57 : SEGDES MTABLE 57 : CALL ERREUR (39) 58 : RETURN 59 : ENDIF 60 : IF ((MTABTI(1).NE.'ENTIER ').OR.(MTABII(1).NE.1))THEN 61 : MOTERR(1:8)='ENTIER ' 62 : INTERR(1)=IRET 63 : INTERR(2)=1 64 : SEGDES MTABLE 64 : CALL ERREUR (58) 65 : RETURN 66 : ENDIF 67 : ITYPE=MTABTV(1) 68 : ITYPIND=MTABTI(1) 69 : IIND=MTABII(1)-1 70 : 70 : CALL LIROBJ('LISTREEL',IRETR,0,IRETOU) 71 : IF(IRETOU.EQ.0) GOTO 1 72 : * 73 : ICHP=1 74 : MLREEL= IRETR 75 : SEGACT MLREEL 76 : * test dime de tab = dime listreel 77 : IF(NB.NE.PROG(/1)) THEN 78 : SEGDES MLREEL 79 : SEGDES MTABLE 79 : CALL ERREUR (217) 80 : RETURN 81 : ENDIF 82 : SEGINI ITA1 83 : SEGINI ITA2 84 : *on teste: si les indices se suivent de 1 a n par pas de 1 85 : * : si les champs sont tous du meme type 86 : * et on remplit les vecteurs ITA1 et TA2 87 : 88 : DO 5 IJ=1,NB 89 : IF( IJ.NE.MTABII(IJ))THEN 90 : C print *,'les indices ne se suivent pas' 91 : SEGDES MTABLE 92 : SEGSUP ITA1 93 : SEGSUP ITA2 94 : SEGDES MLREEL 94 : CALL ERREUR (211) 95 : RETURN 96 : ENDIF 97 : IF (MTABTV(IJ).NE.ITYPE) THEN 98 : MOTERR(1:8)=ITYPE 99 : SEGDES MTABLE 100 : SEGSUP ITA1 101 : SEGSUP ITA2 102 : SEGDES MLREEL 102 : CALL ERREUR (225) 103 : RETURN 104 : ENDIF 105 : C extraction des champs 106 : ITA1(**)=MTABIV(IJ) 107 : C extraction des reels 108 : TA2(**)=(PROG (IJ)) 109 : 5 CONTINUE 110 : SEGDES MTABLE 111 : SEGDES MLREEL 112 : C 113 : GOTO 100 114 : C 115 : C PAS D OPERANDE CORRECT TROUVE 116 : C 116 : 1 CALL QUETYP(MOTERR(1:8),0,IRETOU) 117 : IF(IRETOU.NE.0) THEN 117 : CALL ERREUR (39) 118 : ELSE 118 : CALL ERREUR(533) 119 : ENDIF 120 : RETURN 121 : * 122 : 10 ICHP=1 123 : SEGINI ITA1 124 : SEGINI ITA2 125 : ITA1(**)=IRET 125 : CALL LIRREE(RET,1,IRETOU) 126 : IF(IERR.NE.0) GOTO 5001 127 : TA2(**)=RET 127 : 11 CALL LIROBJ(ITYPE,IRET,0,IRETOU) 128 : IF(IRETOU.EQ.0) GO TO 100 129 : ITA1(**)=IRET 129 : CALL LIRREE(RET,1,IRETOU) 130 : IF(IERR.NE.0) GOTO 5001 131 : TA2(**)=RET 132 : GOTO 11 133 : * 134 : 100 CONTINUE 135 : SEGDES ITA1,ITA2 135 : IF(ITYPE.EQ.ITCHPO) CALL COMBIL(ITA1,ITA2,IRET) 135 : IF(ITYPE.EQ.ITCHAM) CALL COMBYL(ITA1,ITA2,IRET) 136 : IF(IERR.NE.0) GOTO 5001 137 : * 138 : IF(ICHP.EQ.1) THEN 138 : CALL ECROBJ(ITYPE,IRET) 139 : ENDIF 140 : * 141 : 5001 CONTINUE 142 : SEGSUP ITA1 143 : SEGSUP ITA2 144 : * 145 : RETURN 146 : END 147 : 148 :
© Cast3M 2003 - All rights reserved.
Disclaimer