Sources Esope | Cast3M

excomp
C EXCOMP    SOURCE    JK148537  25/01/29    21:15:02     12136          
      SUBROUTINE EXCOMP
C=======================================================================
C
C     OPERATEUR EXTRACTION D UNE COMPOSANTE D UN CHPOINT
C                                           D UN MCHAML
C                          DE QUELQUES COMPOSANTES  D UN MCHAML
C
C     CH2 =  EXCO |  MOT1  (MOT2)  | (n1) (n2) ('NOID') CH1 ...
C                 | LISM1  (LISM2) |
C
C           ... ('NATURE' |'INDETER'| )  ;
C                         |'DIFFUS' |
C                         |'DISCRET'|
C
C=======================================================================
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
-INC SMCOORD
-INC SMLMOTS
-INC SMCHPOI
-INC SMCHAML
 
      CHARACTER*4 NOVE(1),NATU(3)
      CHARACTER*(LOCOMP) MOT,MOT2,MOT3
      DATA NOVE/'NOID'/
      DATA NATU/'INDE','DIFF','DISC'/
 
C
C       LISTE DE MOT OU MOT SIMPLE
C
 
      MOT  =' '
      LISM1= 0
      LISM2= 0
C     Syntaxe 2 : on tente de lire un LISTMOTS
      CALL LIROBJ('LISTMOTS',LISM1,0,IRT1)
C     Syntaxe 1 : si abscence de LISTMOTS, on lit un simple MOT
      IF(IRT1.EQ.0) THEN
        MOT2='SCAL'
        CALL LIRCHA(MOT,1,IRETOU)
        IF(IERR.NE.0) RETURN
      ENDIF
C
Cbp : Lecture eventuelle de l'harmonique de Fourier en entre /sortie
      CALL LIRENT(NIF1,0,IRET1)
      IF(IRET1.NE.0) THEN
        CALL LIRENT(NIF2,0,IRET2)
        IF(IRET2.EQ.0) NIF2=NIFOUR
      ELSE
        if(ifour.eq.1) then
          NIF1=NIFOUR
          NIF2=NIFOUR
        else
          NIF1 = 0
          NIF2 = 0
        endif
      ENDIF
      IF(IERR.NE.0) RETURN
C     
C     Lecture de l'option 'NOID'
      CALL LIRMOT(NOVE,1,NOID,0)
*  pv NOID automatique le 29/2/24
      NOID=1
C
C     Pour la syntaxe 2, on tente la lecture d'un second LISTMLOTS
      IF(IRT1.NE.0) THEN
         CALL LIROBJ('LISTMOTS',LISM2,0,IRL2)
      ENDIF
C
C
C-----------------------------------------------
C       CAS D'UN OBJET CHPOINT
C-----------------------------------------------
      CALL LIROBJ('CHPOINT ',IPCH1,0,IRT2)
      IF(IRT2.EQ.0) GOTO 100
      CALL ACTOBJ('CHPOINT ',IPCH1,1)
C     On essaie de lire le nouveau nom et la nature (facultatif)
      CALL LIRCHA(MOT2,0,IRETOU)
      MCHPOI = IPCH1
      JATT1 = JATTRI(1)+1
      IF (IRETOU .GE. 1) THEN
         IF (MOT2(1:4) .EQ. 'NATU' ) THEN
C               jatt va stocker la nature
            CALL LIRMOT(NATU,3,JATT1,1)
            IF(IERR.NE.0) RETURN
            MOT2='SCAL'
         ELSE
C           MOT2 est le nouveau nom de la composante
C           on essaie a nouveau de lire la nature
            CALL LIRCHA(MOT3,0,IRETOU)
            IF (IRETOU .GE. 1) THEN
               IF (MOT3(1:4) .EQ. 'NATU' ) THEN
                 CALL LIRMOT(NATU,3,JATT1,1)
                 IF(IERR.NE.0) RETURN
               ELSE
C              'NATU' n'est pas specifie on continue...
                  CALL REFUS
               ENDIF
            ENDIF
         ENDIF
      ENDIF
 
C     Syntaxe 1 (avec des MOTs simples)
      IF (LISM1.EQ.0) THEN
         CALL EXCOPP(IPCH1,MOT,NIF1,IPCH2,MOT2,NIF2,NOID)
         IF(IERR.NE.0) RETURN
C     Syntaxe 2 (avec des LISTMOTS)
      ELSE
         MLMOTS=LISM1
         SEGACT MLMOTS
C        Erreur si les deux LISTMOTS ne sont pas de meme dimension
         IF (LISM2.NE.0) THEN
            MLMOT2=LISM2
            SEGACT,MLMOT2
            IF (MOTS(/2).NE.MLMOT2.MOTS(/2)) THEN
               CALL ERREUR(217)
               RETURN
            ENDIF
         ENDIF
         IPCH2=0
 
 
C        Erreur si le premier LISTMOTS est vide
         IF (MOTS(/2).EQ.0) THEN
            NAT   =1
            NSOUPO=0
            SEGINI,MCHPOI
            IPCH2 =MCHPOI
 
C           On place un soucis avec le numero de l'erreur qu'on pourrait emettre
            MOTERR(1:8)='LISTMOTS'
            INTERR(1)=MLMOTS
            CALL SOUCIS(356)
 
         ELSE         
C          On fait le job en bouclant sur les mots
           DO IM=1,MOTS(/2)
              MOT =MOTS(IM)
              IF (LISM2.NE.0) THEN
                 MOT2=MLMOT2.MOTS(IM)
              ELSE
                 MOT2=MOTS(IM)
              ENDIF
 
              CALL EXCOPP(IPCH1,MOT,NIF1,IPCH3,MOT2,NIF2,NOID)
              IF(IERR.NE.0) RETURN
 
              IF(IPCH2.EQ.0) THEN
                 IPCH2=IPCH3
              ELSE
                 CALL ADCHPO(IPCH2,IPCH3,IPCHR,1D0,1D0)
                 IF(IERR.NE.0) RETURN
                 IPCH2=IPCHR
              ENDIF
           ENDDO
         ENDIF
      ENDIF
C     On ajuste la nature du champ
      MCHPOI=IPCH2
      mochde='CHPOINT cree par EXCOMP'
      mtypoi='SCALAIRE'
      JATTRI(1)=JATT1-1
 
C     On ecrit le CHPOINT resultat dans la pile
      CALL ACTOBJ('CHPOINT ',IPCH2,1)
      CALL ECROBJ('CHPOINT ',IPCH2)
      RETURN
 
 
C ---------------------------------------------
C       CAS D'UN OBJET MCHAML
C ---------------------------------------------
  100 CONTINUE
      CALL LIROBJ('MCHAML  ',ICHE1,0,IRT3)
      IF(IRT3.EQ.0) GO TO  300
      CALL ACTOBJ('MCHAML  ',ICHE1,1)
      CALL LIRCHA(MOT2,0,IRETOU)
      IF(IRETOU.EQ.0) MOT2=MOT
      IF (LISM1.EQ.0) THEN
C        Syntaxe 1 (avec des MOTs simples)
         CALL EXCOC1(ICHE1,MOT,ICHE2,MOT2,NOID)
         IF(IERR.NE.0) RETURN
      ELSE
C        Syntaxe 2 (avec des LISTMOTS)
         MLMOTS=LISM1
         SEGACT MLMOTS
 
C        Erreur si les deux LISTMOTS ne sont pas de meme dimension
         IF (LISM2.NE.0) THEN
            MLMOT2=LISM2
            SEGACT,MLMOT2
            IF (MOTS(/2).NE.MLMOT2.MOTS(/2)) THEN
               CALL ERREUR(217)
               RETURN
            ENDIF
 
         ELSE         
           MLMOT2 = MLMOTS
         ENDIF
 
C        Si le premier LISTMOTS est vide
         IF (MOTS(/2).EQ.0) THEN
           N1=0
           N3=0
           L1=8
 
           SEGINI,MCHELM
           ICHE2 =MCHELM
           IFOCHE=IFOMOD
           TITCHE='        '
 
C          On place un soucis avec le numero de l'erreur qu'on pourrait emettre
           MOTERR(1:8)='LISTMOTS'
           INTERR(1)=MLMOTS
           CALL SOUCIS(356)
 
         ELSE
           CALL EXCOC2(ICHE1,MLMOTS,ICHE2,MLMOT2,NOID)  
         ENDIF       
      ENDIF
 
C     On ecrit le MCHAML resultat dans la pile
      CALL ACTOBJ('MCHAML  ',ICHE2,1)
      CALL ECROBJ('MCHAML  ',ICHE2)
      RETURN
C
C    PAS D OPERANDE CORRECTE TROUVE
C
 300  CALL QUETYP(MOTERR(1:8),0,IRETOU)
      IF(IRETOU.NE.0) THEN
         CALL ERREUR (39)
      ELSE
         CALL ERREUR(533)
      ENDIF
      END