Esope source files

   1 : C CHKESC    SOURCE    PV        12/07/09    21:15:00     7430           
   2 :       SUBROUTINE CHKESC(irt,imena)
   3 : *  chkesc regarde si il y a dans l'instruction un objet de type //
   4 : *  si c'est le cas, il rajoute assi tous dans l'instruction
   5 :       IMPLICIT INTEGER(I-N)
   6 :       IMPLICIT REAL*8(A-H,O-Z)
   7 :       character*8 typobj,charre            
   8 :       logical logr1,logr2,ltelq
   9 :       character*4 lesmot(6),lesmo2(8)
  10 : * lesmot = liste des opérateurs gérant les objest esclaves 
  11 :       data lesmot/'ASSI','LIST','DETR','ETG ','DIME','TYPE'/
  12 : * lesmo2 = liste des opérateurs demandant une fusion des objets
  13 : * avant de les appeler
  14 :       data lesmo2/'MASQ','MAXI','MINI','TYPE','EXIS'
  15 :      >      ,'FORM','NLOC','TRAC'/
  16 : * 
  17 : * pour tout autre opérateur en présence de table esclave
  18 : * (sauf de type chpoint ou rigidite) 
  19 : * on insere "assis tous" au début de la phrase gibiane
  20 : * sans faire de fusion.  (les tables esclave de chpoint, de rigidite
  21 : *  et de logique sont toujours assemblée)
  22 : * en sortie  : irt=1 veut dire allez dans assistant 
  23 : *            : imena=0 veut dire ne pas faire de menage tout de suite
  24 : *              car fusion sans remplacement dans table des objets
  25 : 
  26 : -INC CCNOYAU
  27 : -INC SMTABLE
  28 : -INC CCOPTIO
  29 :       dimension iaz(100)
  30 : *          write(6,*) ' entree dans chkes'
  31 :       ltelq=.true.
  32 :       iredu=0
  33 :       irt=0
  34 :       iluob=0
  35 :       imena=1
  36 : *      write(6,*) ' entrée dans chkesc'
  36 :       call lirmot(lesmot,6,iv,0)
  37 :       if (iv.ne.0) then
  37 :        call refus
  38 : *       write (6,*) ' chkesc ',lesmot(iv)
  39 :        return
  40 :       endif
  40 :       call lirmot(lesmo2,8,iv,0)
  41 :       if (iv.ne.0) then
  41 :        call refus
  42 :        iredu=1
  43 : *      write (6,*) ' chkesc reduction ',lesmo2(iv)
  44 :       endif
  45 : *
  46 : * ibloqm =0 permet à gibiane de lire au delà des mots          
  47 :       ibloqm=0
  47 : *      call lirobj('MCHAML',iret,0,iretou)
  48 : *      if (iretou.ne.0) then
  48 : *        call refus
  49 : *        iredu=1
  50 : *      endif
  50 :       call lirobj('PROCEDUR',iret,0,iretou)
  51 :       if (iretou.ne.0) then
  51 :         call refus
  52 :         return
  53 :       endif
  54 :       ibloqm=1
  55 :       iasss=0
  56 :       do 10 iccc=1,100
  57 :       iblqm=0
  57 :       call lirtab('ESCLAVE',mtable,0,iretou)
  58 : *      write(6,*) ' mtable iretou', mtable,iretou
  59 :       iluob=iluob+1
  60 :       iaz(iluob)=imotlu
  61 :       iblqm=1
  62 : *     write (6,*) ' chkesc lectab iret iretou ',lectab,iret,iretou
  63 :       if (iretou.eq.0) then
  64 :          if(iasss.eq.1)then
  65 :            go to 100
  66 :          else
  67 :             return
  68 :          endif
  69 :       endif
  70 :       typobj=' '
  71 :        segact mtable
  72 :        ml=mlotab
  73 :        ind=mtabii(2)
  74 : *      write (6,*) ' ml ind ',ml,ind
  74 :       call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,typobj,ivalre,
  75 :      >    xvalre,charre,logr1,id1)
  76 :       if (ierr.ne.0) return
  77 : *     write (6,*) ' type de la table ',typobj
  78 :       if ((typobj.eq.'MCHAML'.or.typobj.eq.'MMODEL'.or.
  79 :      >  typobj.eq.'MAILLAGE'.or.typobj.eq.'ENTIER')
  80 :      >    .and.iredu.eq.0) then
  81 :           iasss=1
  82 :           go to 10
  83 :       endif
  84 :       if (typobj.eq.'CHPOINT'.or.typobj.eq.'RIGIDITE'.or.
  85 :      >    typobj.eq.'LOGIQUE'.or.typobj.eq.'MCHAML'.or.
  86 :      >    typobj.eq.'MMODEL'.OR.typobj.eq.'MAILLAGE'.OR.
  87 :      >    typobj.eq.'MATRIK'
  88 :      >     ) then
  89 :       do i=3,ml
  90 :        segact mtable
  91 :        ind=mtabii(i)
  92 : *      write (6,*) ' i ind ',i,ind
  92 :        call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,typobj,ivalre,
  93 :      >   xvalre,charre,logr2,id2)
  94 :        if (ierr.ne.0) return
  94 :        if (typobj.eq.'CHPOINT') call fuchpo(id1,id2,iretou)
  94 :        if (typobj.eq.'RIGIDITE') call fusrig(id1,id2,iretou)
  94 :        if (typobj.eq.'MATRIK'  ) call fusmtk(id1,id2,iretou)
  95 :        if (typobj.eq.'LOGIQUE') logr1=logr1.or.logr2
  95 :        if (typobj.eq.'MCHAML') call fuschl(id1,id2,iretou)
  95 :        if (typobj.eq.'MMODEL') call fusmod(id1,id2,iretou)
  95 :        if (typobj.eq.'MAILLAGE') call fuse(id1,id2,iretou,ltelq)
  96 :        id1=iretou 
  97 :       enddo
  97 :       if (typobj.eq.'LOGIQUE') call poslog(logr1,id1)
  98 :       if(typobj.eq.'MATRIK'.or.typobj.eq.'MCHAML'.or.typobj.eq.'MMODEL'
  99 :      $ .or.typobj.eq.'MAILLAGE')then
 100 :         imena=0
 101 :       endif
 101 :       call rmpgbn(mtable,id1,typobj)       
 102 : *     write (6,*) ' reduction de l objet ',typobj
 103 :       else
 104 : *        write (6,*) ' type ',typobj,' inconnu dans chkesc '
 105 :       
 105 :       call trbac
 105 :       call erreur(5)
 106 :       endif
 107 : 10    continue
 108 :       
 109 : *
 110 :  100  continue
 110 : *      call refus
 111 :        do iazi=1,iluob
 112 :          imotlu=iaz(iazi)
 113 :          jpoob1(imotlu)=.TRUE.
 114 :          IF(IBPILE.GT.IMOTLU) IBPILE=IMOTLU                                        
 115 :          IF(IHPILE.LT.IMOTLU) IHPILE=IMOTLU           
 116 :        enddo
 117 :       charre=' '
 117 :       call lircha(charre,0,iretou)
 117 :       if (iretou.ne.0) call refus
 118 :       if (iretou.eq.0) return
 119 : *       write (6,*) ' parallelisation de l instruction ',charre
 119 : **    call trbac
 120 :       irt=1
 120 : *      call ecrcha('TOUS')
 120 : *      call ecrcha('ASSI')
 121 :       end
 122 :  
 123 :  
 124 :  
 125 :  
 126 :