Télécharger coli.eso

Retour à la liste

coli
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
 
 
 
 
 

© Cast3M 2003 - Tous droits réservés.
Mentions légales