Télécharger chkesc.eso

Retour à la liste

chkesc
C CHKESC    SOURCE    PV090527  25/03/06    21:15:01     12172          
      SUBROUTINE CHKESC(IRT,IMENA)
 
C  CHKESC REGARDE SI IL Y A DANS L'INSTRUCTION UN OBJET DE TYPE //
C  SI C'EST LE CAS, IL RAJOUTE ASSI TOUS DANS L'INSTRUCTION
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
-INC CCNOYAU
-INC SMTABLE
-INC SMCHAML
-INC SMMODEL
 
-INC PPARAM
-INC CCOPTIO
 
      CHARACTER*8 TYPOBJ,CHA8,CHARRE,CHACRE
      LOGICAL LOGR1,LOGR2
      CHARACTER*(LOCHAI) LACHAINE
 
      PARAMETER (NBMO1=8)
      CHARACTER*4 LESMOT(NBMO1)
 
C LESMOT = LISTE DES OPÉRATEURS GÉRANT LES OBJEST ESCLAVES
      DATA LESMOT/'ASSI','LIST','DETR','ETG ',
     &            'TYPE','DEBP','FINP','RESP'/
 
      PARAMETER (NBMO2=46)
      CHARACTER*4 LESMO2(NBMO2)
C       LESMO2 = LISTE DES OPÉRATEURS DEMANDANT UNE FUSION DES OBJETS
C                AVANT DE LES APPELER
      DATA LESMO2/'MASQ','TYPE','EXIS','FORM','NLOC','TRAC','PROI',
     &            'ELIM','POIN','NOEU','ARET','CERC','DROI','CONT',
     &            'DALL','ENVE','FACE','REGL','ROTA','SURF','TRAN',
     &            'PAVE','VOLU','PART','AFFI','....','DEPL','DIFF',
     &            'ELEM','HOMO','INCL','INTE','INVE','ORDO','PROJ',
     &            'RAFF','RAFT','REGE','SYME','TOUR','PLUS','MOIN',
     &            'UNIQ','DIME','EXTR','SI  '/
 
      PARAMETER (NBMO3=2)
      CHARACTER*4 LESMO3(NBMO3)
C       LESMO3 = LISTE DES OPERATEURS EXECUTES EN PARALLELE ALORS QU''UN
C                MCHAML (NON //) A ETE LU SANS MMODEL
      DATA LESMO3/'REDU','SOUC'/
 
C     BREDUC : BOOLEEN PERMETTANT D'ENCLENCHER LA FUSION
C     BREMPL : BOOLEEN PERMETTANT DE REMPLACER DANS LA PILE LA TABLE PAR L'OBJET FUSIONNE
      LOGICAL BREDUC,BREMPL,BREDU2,BREMP2,BSPECI
 
C     SID : SEGMENT CONTENANT LES INFORMATIONS POUR LA FUSION DES OBJETS
      SEGMENT SID
C       NBFUS  : NOMBRE D'OBJETS A FUSIONNER
C       IPOINT : POINTEURS A FUSIONNER ou ENTIERS A FUSIONNER (cas particuler MAXI / MINI)
C       BVAL   : LOGIQUES SUR LESQUELS ON FAIT UN ET/OU LOGIQUE
C       XVAL   : REELS A FUSIONNER (cas particuler MAXI / MINI)
C       CVAL   : MOTS  A FUSIONNER (cas particuler MAXI / MINI)
C       CHATYP : MOT DONNANT LE TYPE   D'OBJETS A FUSIONNER
        INTEGER         IPOINT(NBFUS)
        LOGICAL         BVAL  (NBFUS)
        REAL*8          XVAL  (NBFUS)
        CHARACTER*(IC1) CVAL  (NBFUS)
        CHARACTER*8     CHATYP,CREATE
      ENDSEGMENT
 
C
C POUR TOUT AUTRE OPÉRATEUR EN PRÉSENCE DE TABLE ESCLAVE
C (SAUF DE TYPE CHPOINT OU RIGIDITE)
C ON INSERE "ASSIS TOUS" AU DÉBUT DE LA PHRASE GIBIANE
C SANS FAIRE DE FUSION.
C LES TABLES ESCLAVE DE CHPOINT, DE RIGIDITE, DE FLOTTANT ET  DE LOGIQUE
C SONT TOUJOURS ASSEMBLÉES
C EN SORTIE  : IRT  =1 VEUT DIRE ALLER DANS ASSISTANT
C            : IMENA=0 VEUT DIRE NE PAS FAIRE DE MENAGE TOUT DE SUITE
C              CAR FUSION SANS REMPLACEMENT DANS TABLE DES OBJETS
 
      DIMENSION IAZ(100)
 
 
*          WRITE(6,*) ' ENTREE DANS CHKESC'
      BREDUC = .FALSE.
      BREDU2 = .FALSE.
      BREMPL = .FALSE.
      BSPECI = .FALSE.
      IRT    = 0
      ILUOB  = 0
      IMENA  = 1
 
      IREPRO = 0
      IREMOD = 0
      IRECHA = 0
      IREESC = 0
      IRELOB = 0
      IMOT1  = 0
      IMOT2  = 0
      IMOT3  = 0
      IRETOU = 0
      IRET   = 0
 
C IBLQM =0 PERMET À GIBIANE DE LIRE AU DELÀ DES MOTS
      IBLQM=0
 
      CALL LIROBJ('PROCEDUR',IRET,0,IREPRO)
      IF (IREPRO.NE.0) THEN
        CALL REFUS
C       WRITE (6,*) ' CHKESC : Lecture d''une PROCEDUR'
        RETURN
      ENDIF
 
      CALL LIRCHA(LACHAINE,0,IREMOT)
      IF (IREMOT.ne.0) THEN
        CALL REFUS
      ELSE
**      write(6,*) 'chkesc pas de mot'
        RETURN
      ENDIF
 
 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     Lecture de MOTS et d''OBJETS intervenants dans la LOGIQUE de CHKESC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      CALL LIRMOT(LESMOT,NBMO1,IMOT1,0)
      IF (IMOT1.NE.0) THEN
        CALL REFUS
C       WRITE (6,*) ' CHKESC ',LESMOT(IMOT1)
        RETURN
      ENDIF
 
      CALL LIRMOT(LESMO2,NBMO2,IMOT2,0)
      IF (IMOT2.NE.0) THEN
C        IF (IMOT2 .EQ. 7) THEN
CC         Cas un peu particulier de l''operateur 'PROI'
C          BSPECI = .TRUE.
C        ENDIF
        CALL REFUS
      ELSE
        CALL LIRMOT(LESMO3,NBMO3,IMOT3,0)
          IF (IMOT3.NE.0) THEN
            CALL REFUS
          ENDIF
      ENDIF
 
      CALL LIROBJ('MMODEL',IRET,0,IREMOD)
      IF (IREMOD.NE.0) THEN
        MMODEL=IRET
        CALL REFUS
      ENDIF
 
      CALL LIROBJ('MCHAML',IRET,0,IRECHA)
      IF (IRECHA.NE.0) THEN
        MCHELM=IRET
        CALL REFUS
      ENDIF
 
 
 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     Logique generale de Fusion & Remplacement des OBJETS
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      IF    (IMOT2.NE.0) THEN
C       Fusion pour les Operateurs de LESMO2
        BREDUC=.TRUE.
        BREMPL=.FALSE.
 
      ELSEIF(IMOT3 .NE. 0) THEN
        IF (IREMOD .NE. 0) THEN
C         Un MMODEL dans 'REDU' enclenche la fusion sans remplacement
          BREDUC=.TRUE.
          BREMPL=.FALSE.
        ENDIF
 
      ELSEIF ((IRECHA .NE. 0) .OR. (IREMOD .NE. 0)) THEN
C       Un MMODEL ou un MCHAML enclenche la fusion avec remplacement
        BREDUC=.TRUE.
        BREMPL=.TRUE.
      ENDIF
 
 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     Boucle sur les arguments de la ligne decodee
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      IASSS=0
 
C     Cas de souci
      IF (IMOT3.EQ.2) then
        IASSS=1
      ENDIF
      DO 10 ICCC=1,100
        IBLQM=0
        CALL LIRTAB('ESCLAVE',MTABLE,0,IREESC)
        CALL LIROBJ('LISTOBJE',IPLOBJ,0,IRELOB)
        ILUOB=ILUOB+1
        IAZ(ILUOB)=IMOTLU
        IBLQM=1
        IF (IREESC.EQ.0.AND.IRELOB.EQ.0) THEN
           IF(IASSS.EQ.1)THEN
             GOTO 100
           ELSE
C              WRITE(6,*)'CHKESC : Sortie n_3'
              RETURN
           ENDIF
        ENDIF
 
C------ CAS DU LISTOBJE
 
        IF (IRELOB.NE.0) THEN
          IASSS = 1 
          GOTO 10
        ENDIF
 
C------ CAS DE LA TABLE ESCLAVE 
 
        TYPOBJ='        '
 
C       RECHERCHE DU CREATEUR (MTABLE ressort SEGACT dans les ASSISTANT)
        CALL ACCTAB(MTABLE,'MOT     ',IND ,0.D0  ,'CREATEUR',.TRUE.,0  ,
     &                     'MOT     ',IVALRE,XVALRE,CHACRE  ,LOGR1 ,ID1)
        IF (IERR.NE.0) RETURN
 
        ML=MLOTAB
C       DIMENSIONNEMENT DU SEGMENT SID A (ML - 2) a cause des indices 'SOUSTYPE' et 'CREATEUR'
        NBFUS = ML - 2
*  a voir quoi mettre dans ic1?
        IC1 = 8
        SEGINI,SID
        SID.CREATE=CHACRE
        NBENT = 0
 
        IND=1
        CALL ACCTAB(MTABLE,'ENTIER',IND   ,0.D0  ,'  ',.TRUE.,0,
     &                      TYPOBJ ,IVALRE,XVALRE,CHARRE,LOGR1 ,ID1)
        IF (IERR.NE.0) RETURN
 
        IF ((IRECHA .NE. 0) .AND. (TYPOBJ .EQ. 'MCHAML')) THEN
C         PLANTE SUR LES COMMANDES AVEC MCHAML // ET NORMAUX
C          WRITE(*,*)'Utilisation de MCHAML // et MCHAML normaux'
C          CALL TRBAC
C          CALL ERREUR(21)
C          WRITE(6,*)'CHKESC : Sortie n_4'
C          RETURN
        ENDIF
 
        IF ((IRECHA .NE. 0) .AND. (TYPOBJ .EQ. 'MMODEL') .AND.
     &      (IMOT3 .EQ. 0)) THEN
C         PLANTE SUR LES COMMANDES AVEC MMODEL // ET MCHAML NORMAUX
C          WRITE(*,*)'Utilisation de MMODEL // et MCHAML normaux'
C          CALL TRBAC
C          CALL ERREUR(21)
C          WRITE(6,*)'CHKESC : Sortie n_5'
C          RETURN
        ENDIF
 
        IF (IMOT2 .EQ. 0) THEN
          IF (TYPOBJ .EQ. 'MMODEL') THEN
C           PAS DE REDUCTION SI UN MMODEL ESCLAVE EST RENCONTRE
C     write(6,*) ' Chkesc : traitement modele'
            BREDUC = .FALSE.
            IASSS=1
            GOTO 10
 
          ELSE IF((TYPOBJ.EQ.'MCHAML  '.OR. TYPOBJ .EQ. 'MAILLAGE' .OR.
     &            TYPOBJ.EQ.'ENTIER  ') .AND. (.NOT. BREDUC)) THEN
C     write(6,*) 'Chkesc : traitement maillage'
            IASSS=1
            GOTO 10
          ENDIF
        ELSE IF(BSPECI) THEN
          IASSS=1
          GOTO 10
        ENDIF
 
C       Regles locales de remplacement
        BREDU2 = BREDUC
        BREMP2 = BREMPL
        IF (CHACRE .EQ. 'SOUC') THEN
        ENDIF
        IF     (TYPOBJ .EQ. 'FLOTTANT') THEN
          BREDU2 = .TRUE.
          BREMP2 = .TRUE.
 
          IF     (CHACRE .EQ. 'MAXI') THEN
          ELSEIF (CHACRE .EQ. 'MINI') THEN
          ELSE
            CALL ERREUR(21)
            RETURN
          ENDIF
 
        ELSEIF ((TYPOBJ.EQ.'RIGIDITE') .OR. (TYPOBJ.EQ.'CHPOINT ').OR.
     &          (TYPOBJ.EQ.'LOGIQUE ' )) THEN
          BREDU2 = .TRUE.
          BREMP2 = .TRUE.
        ENDIF
 
        IF (BREDU2) THEN
          IF (TYPOBJ .NE. 'RIGIDITE' .AND. TYPOBJ .NE. 'CHPOINT ' .AND.
     &        TYPOBJ .NE. 'LOGIQUE ' .AND. TYPOBJ .NE. 'FLOTTANT' .AND.
     &        IMOT2  .EQ. 0          .AND. IMOT3.EQ. 0) THEN
C            WRITE(*,*)TYPOBJ,BREMP2,BREMPL
C            WRITE(*,*)'FUSION CHKESC ANORMALE...'
C            CALL ERREUR(21)
C            RETURN
          ENDIF
 
C         REMPLISSAGE DU SEGMENT SID POUR LA FUSION
          NBENT            = NBENT + 1
          SID.IPOINT(NBENT)= ID1
          SID.BVAL  (NBENT)= LOGR1
          SID.XVAL  (NBENT)= XVALRE
          SID.CHATYP       = TYPOBJ
          CHA8             = TYPOBJ
 
          IF (ML .GE. 4) THEN
            DO I=4,ML
C             La TABLE n'est plus SEGDES par acctab pour les ESCLAVES
              IND=i-2
              CALL ACCTAB(MTABLE,'ENTIER',IND   ,0.D0  ,'  ',.TRUE.,0,
     &                          TYPOBJ ,IVALRE,XVALRE,CHARRE,LOGR2 ,ID2)
              IF (IERR.NE.0) RETURN
 
              IF (TYPOBJ .NE. CHA8) THEN
C               ERREUR SI LES TYPES SONT DIFFERENTS ENTRE 2 INDICES DE LA TABLE ESCLAVE
                MOTERR(1:8 ) = CHA8
                MOTERR(9:16) = TYPOBJ
                CALL ERREUR(1045)
                SEGSUP,SID
C               WRITE(6,*)'CHKESC : Sortie n_7'
                RETURN
              ENDIF
 
C             REMPLISSAGE DU SEGMENT SID POUR LA FUSION PAR TOURNOI
              NBENT=NBENT + 1
              SID.IPOINT(NBENT)= ID2
              SID.BVAL(NBENT)  = LOGR2
              SID.XVAL(NBENT)  = XVALRE
            ENDDO
          ENDIF
 
C         LANCEMENT DE LA FUSION DES OBJETS
C          IF (IIMPI .EQ. 215821) THEN
C            WRITE(IOIMP,*)'FUSION ENCLENCHEE DANS CHKESC : ',CHA8,BREMP2
C            CALL TRBAC
C          ENDIF
          ID = SID
          CALL FUNOBJ(ID,ID1,XVALRE,LOGR1)
 
          IF     (TYPOBJ.EQ.'LOGIQUE ') THEN
            CALL POSLOG(LOGR1,ID1)
 
          ELSEIF (TYPOBJ.EQ.'FLOTTANT') THEN
            IF(ID1 .EQ. 0)THEN
              CALL POSREE(XVALRE,ID1)
            ELSE
              CALL ACTOBJ('LISTREEL',ID1,1)
              IMENA=0
            ENDIF
 
          ELSEIF (TYPOBJ.EQ.'ENTIER  ') THEN
C           Il manque la gestion de MAXI et MINI pour ce cas la !
            CALL ACTOBJ('LISTENTI',ID1,1)
            IMENA=0
 
          ELSE
            CALL ACTOBJ(TYPOBJ,ID1,1)
            IMENA=0
          ENDIF
 
C         REMPLACEMENT DE LA TABLE PAR LE RESULTAT DE LA FUSION
C           - Dans la pile GIBIANE
C           - Dans la pile des NOMS si BREMP2 est VRAI
          CALL RMPGBN(MTABLE,ID1,TYPOBJ,BREMP2)
 
        ELSE
          WRITE(IOIMP,*)'ERREUR DANS CHKESC.ESO,',TYPOBJ
          CALL ERREUR(21)
          RETURN
        ENDIF
 
        SEGSUP,SID
10    CONTINUE
 
C
 100  CONTINUE
C      CALL REFUS
       DO IAZI=1,ILUOB
         IMOTLU=IAZ(IAZI)
          IF(IMOTLU.NE.0) THEN
          JPOOB1(IMOTLU)=.TRUE.
          IF(IBPILE.GT.IMOTLU) IBPILE=IMOTLU
          IF(IHPILE.LT.IMOTLU) IHPILE=IMOTLU
         ENDIF
       ENDDO
      CHARRE=' '
      CALL LIRCHA(CHARRE,0,IRETOU)
      IF (IRETOU.NE.0) CALL REFUS
      IF (IRETOU.EQ.0) RETURN
C       CALL TRBAC
      IRT=1
 
C      WRITE(6,*)'CHKESC : Sortie n_8 NORMALE'
      END
 
 
 
 
 
 
 
 
 
 

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