C COLI SOURCE BP208322 15/06/26 21:15:04 8562 SUBROUTINE COLI C======================================================================= C C COMBINAISON LINEAIRE DE CHPOINT OU DE MCHAML C C C OPERATEUR COLI : OBJ = | FLOT1*OBJ1 + FLOT2*OBJ2 + ...... | C | LCHPO LISTREEL | C | TABLE LISTREEL | C C OPERATION POSSIBLE SUR DES CHPOINTS ET DES CHAMELEMS C (sauf dans le cas LISTCHPO) C C - creation : ? C - PASSAGE AUX NOUVEAUX MCHAMLS PAR JM CAMPENON LE 01/91 C - OPERANDES TABLE ET LISTREEL INCORPORES LE 02/98 PAR MO C - LA VERSION DU 02/98 LAISSAIT TROP DE LIBERTE SUR LES INDICES DE C LA TABLE.ON NE PERMET DORENAVANT QUE DES INDICES DE TYPE ENTIER C ALLANT DE 1 a N PAR PAS DE 1 03/98 PAR MO C - extension aux LISTCHPO, 20/05/2015, Benoit Prabel C - extension aux Table de listreel, 25/06/2015, Benoit Prabel C C======================================================================= * IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC SMTABLE -INC SMLREEL -INC SMLCHPO SEGMENT ITA1(0) SEGMENT ITAN(0) * SEGMENT ITA2 REAL*8 TA2(0) ENDSEGMENT * CHARACTER*(8) ITYPE,ITCHPO,ITCHAM,ITTABL,ITYPIND,ITLCHP,ITLREE REAL*8 RET DATA ITCHPO/'CHPOINT '/ DATA ITCHAM/'MCHAML '/ DATA ITTABL/'TABLE '/ DATA ITLCHP/'LISTCHPO'/ DATA ITLREE/'LISTREEL'/ ICHP=0 * NA=nombre d elements NA=0 * C======================================================================= C Tentatives de Lecture d'objets permis en entree C======================================================================= C CHPOINT: CALL LIROBJ(ITCHPO,IRET,0,IRETOU) IF(IRETOU.EQ.0) GOTO 2 ITYPE=ITCHPO GOTO 10 * C MCHAML: 2 CALL LIROBJ(ITCHAM,IRET,0,IRETOU) IF(IRETOU.EQ.0) GOTO 4 ITYPE=ITCHAM GOTO 10 C TABLE et LISTREEL : 4 CALL LIROBJ(ITTABL,IRET,0,IRETOU) IF(IRETOU.NE.0) GOTO 40 C LISTCHPO et LISTREEL : CALL LIROBJ(ITLCHP,IRET,0,IRETOU) IF(IRETOU.NE.0) GOTO 60 C PAS D OPERANDE CORRECT TROUVE 1 CALL QUETYP(MOTERR(1:8),0,IRETOU) IF(IRETOU.NE.0) THEN CALL ERREUR (39) ELSE CALL ERREUR(533) ENDIF RETURN C======================================================================= C Cas CHPOINT et MCHAML (+flottant) C======================================================================= 10 ICHP=1 SEGINI ITA1 SEGINI ITA2 NA=1 ITA1(**)=IRET CALL LIRREE(RET,1,IRETOU) IF(IERR.NE.0) GOTO 5001 TA2(**)=RET c on boucle jusqu a ne plus lire de champ ITYPE, puis goto 100 11 CALL LIROBJ(ITYPE,IRET,0,IRETOU) IF(IRETOU.EQ.0) GOTO 100 NA=NA+1 ITA1(**)=IRET CALL LIRREE(RET,1,IRETOU) IF(IERR.NE.0) GOTO 5001 TA2(**)=RET GOTO 11 C======================================================================= C Cas TABLE (+listreel) C======================================================================= 40 MTABLE=IRET SEGACT MTABLE NB=MLOTAB **** + listreel CALL LIROBJ('LISTREEL',IRETR,0,IRETOU) IF(IRETOU.EQ.0) GOTO 1 MLREEL= IRETR SEGACT MLREEL **** table de LISTREELs ou de CHPOINT ou de MCHAML SEGINI ITA1 SEGINI ITA2 NA = 0 ITYPE=' ' DO 50 IB=1,NB IF(MTABTI(IB).NE.'ENTIER ') GOTO 50 IF(NA.EQ.0) ITYPE=MTABTV(IB) IF(MTABTV(IB).NE.ITYPE) THEN SEGSUP ITA1,ITA2 SEGDES MTABLE,MLREEL WRITE(ioimp,*) 'Objet de type',MTABTV(IB), & ' au lieu de ',ITYPE,' attendu' CALL ERREUR(39) RETURN ENDIF c ici, tout se passe bien NA = NA + 1 IJ = MTABII(IB) C extraction des LISTREELs ou de CHPOINT ou de MCHAML ITA1(**)=MTABIV(IB) C extraction des reels IF (IJ.gt.PROG(/1)) THEN SEGSUP ITA1,ITA2 SEGDES MLREEL,MTABLE WRITE(ioimp,*) 'Indice',IJ, & ' au dela de la dimesnion du listreel' CALL ERREUR (217) RETURN ENDIF TA2(**)=(PROG(IJ)) 50 CONTINUE SEGDES MTABLE,MLREEL **** type d'objets admis ou pas ? IF(ITYPE.eq.ITLREE.OR.ITYPE.eq.ITCHPO.OR.ITYPE.eq.ITCHAM) THEN ICHP=1 GOTO 100 ELSE SEGSUP ITA1,ITA2 WRITE(ioimp,*) 'Type d objet interdit !' CALL ERREUR (225) RETURN ENDIF C======================================================================= C Cas LISTCHPO (+listreel) C======================================================================= 60 MLCHPO=IRET SEGACT MLCHPO NA=ICHPOI(/1) ITYPE=ITCHPO ICHP=1 c lecture du listreel des coefficients CALL LIROBJ('LISTREEL',IRETR,0,IRETOU) IF(IRETOU.EQ.0) THEN SEGDES,MLCHPO GOTO 1 ENDIF MLREEL= IRETR SEGACT MLREEL * test dime de tab = dime listreel IF(NA.NE.PROG(/1)) THEN SEGDES MLREEL SEGDES MLCHPO CALL ERREUR (217) RETURN ENDIF SEGINI ITA1 SEGINI ITA2 DO 61 IJ=1,NA C extraction des champs ITA1(**)=ICHPOI(IJ) C extraction des reels TA2(**)=PROG (IJ) 61 CONTINUE SEGDES MLCHPO SEGDES MLREEL C GOTO 100 C======================================================================= C Calcul effectif de la combinaison lineaire C======================================================================= 100 CONTINUE c write(ioimp,*) 'ITYPE=',ITYPE c write(ioimp,*) 'ITA1=',(ITA1(iou),iou=1,NA) c write(ioimp,*) ' TA2=',(TA2(iou),iou=1,NA) *bp SEGDES ITA1,ITA2 *bp IF(ITYPE.EQ.ITCHPO) CALL COMBIL(ITA1,ITA2,IRET) *bp IF(ITYPE.EQ.ITCHAM) CALL COMBYL(ITA1,ITA2,IRET) IF(ITYPE.EQ.ITCHPO) CALL COMBIL(ITA1,ITA2,NA,IRET) IF(ITYPE.EQ.ITCHAM) CALL COMBYL(ITA1,ITA2,NA,IRET) IF(ITYPE.EQ.ITLREE) CALL COLILR(ITA1,ITA2,NA,IRET) IF(IERR.NE.0) GOTO 5001 * * Ecriture de l'objet resultat IF(ICHP.EQ.1) THEN CALL ECROBJ(ITYPE,IRET) ENDIF * Fin normale 5001 CONTINUE SEGSUP ITA1 SEGSUP ITA2 * RETURN END