Sources Esope | Cast3M

choi
C CHOI      SOURCE    OF166741  24/01/09    21:15:05     9733           
 
C  positionnement d'un ensemble de flags
 
      SUBROUTINE CHOI
 
      IMPLICIT INTEGER(I-N)     
      IMPLICIT REAL*8(A-H,O-Z)
-INC PPARAM
-INC CCOPTIO
-INC CCNOYAU
 
-INC SMLREEL
-INC SMEVOLL
-INC SMTABLE
 
      EXTERNAL LONG
 
      character*(LOCHAI) choi2, messag, mesdes
      character*(LONOM) nomlog
      character*(3) oui,non
      character*(16) char_z
      character*(8) typobj
 
      PARAMETER (nlogm = 40)
      integer ipla(nlogm)
      character*(LONOM) choix(nlogm)
      logical vale(nlogm)
      logical b_z
 
C Quelques initialisations :
      oui = '(X)'
      non = '( )'
 
      DO i = 1, nlogm
        vale(i)  = .false.
        choix(i) = '                        '
      ENDDO
 
      mtable = 0
      mevoll = 0
      kevoll = 0
      mlree1 = 0
      mlree2 = 0
 
C Lecture du MESSAGE (CHAINE) :
      CALL LIRCHA(messag,1,iretou)
      if (ierr.ne.0) return
      ldes = iretou
      if (iretou.eq.0) messag = 'CHOIx :'
      lmes = LONG(messag)
 
      if (lmes.gt.72) then
        write(ioimp,*) 'Message trop long (max. 72)'
        call erreur(21)
        return
      endif
 
C Recuperation des noms a proposer (erreur en cas de doublon ?)
      nblu  = 0
      nbr   = 0
      llong = 8
      DO i = 1, nlogm
        call lirlog(b_z,0,iretou)
        if (ierr.ne.0) return
        if (iretou.eq.0) goto 11
        nomlog = '    '
        call quenom(nomlog)
        if (ierr.ne.0) return
        nblu = nblu + 1
        CALL PLACE(choix,nbr,irep,nomlog)
        IF (irep.EQ.0) THEN
          nbr = nbr + 1
          choix(nbr) = nomlog
          vale(nbr)  = b_z
          ipla(nblu) = nbr
        ELSE
c*          write(ioimp,*) 'Logique "',nomlog(1:LONG(nomlog)),
c*     &                   '" deja fourni !',irep
c*          call erreur(21)
c*          return
          ipla(nblu) = irep
        ENDIF
        llong = MAX(llong,LONG(nomlog))
      ENDDO
  11  continue
      if (nbr.eq.0) then
        write(ioimp,*) 'Manque des arguments logiques !'
        call erreur(21)
        return
      endif
* lcase = Taille de la case : "(*) nomvariable_de_8_a_LONOM_caracteres"
      ncase = nbr + 1
      lcase = 4 + llong
      if (ncase*lcase.gt.LOCHAI) then
        write(ioimp,*) 'Trop de logiques/Noms trop longs'
        call erreur(21)
        return
      endif
 
C Operateur utile en trace interactif ('TRAC' 'X   ' ou 'OPEN')
C Pour les autres modes, on prend les valeurs telles que fournies.
      IF (IOGRA.NE.2 .AND. IOGRA.NE.6) GOTO 50
 
C Trace vide (avec messag = chaine lue par operateur CHOI) :
C* ev_z = 'EVOL' 'MANU' ('PROG' 0.1) ('PROG' 0.5) ;
C* tab_z = 'TABLE' ; tab_z. 1 = 'MOT' 'NOLI LABEL Operateur_CHOI_:_messag' ;
C* 'DESSIN' ev_z 'XBOR' 0. 1. 'YBOR' 0. 1. 'XGRA' 1. 'YGRA' 1. 'NCLK' tab_z ;
      jg = 1
      SEGINI,mlree1,mlree2
      mlree1.prog(1) = 0.1
      mlree2.prog(1) = 0.5
      SEGINI,kevoll
      kevoll.iprogx = mlree1
      kevoll.iprogy = mlree2
      kevoll.numevx = 0
      kevoll.numevy = 'REEL'
      kevoll.typx   = 'LISTREEL'
      kevoll.typy   = 'LISTREEL'
      kevoll.nomevx = ' '
      kevoll.nomevy = ' '
      kevoll.kevtex = ' '
      n=1
      SEGINI,mevoll
      mevoll.ityevo='REEL'
      mevoll.ievtex=' '
      mevoll.ievtex(1:lmes)=messag(1:lmes)
      mevoll.ievoll(1)=kevoll
      mesdes = ' '
      mesdes(1:27) = 'NOLI LABEL Operateur_CHOI_:'
      IF (ldes.GT.0) THEN
        mesdes(28:28) = '_'
        i_z = LOCHAI-28
        if (ldes.gt.i_z) then
          mesdes(28+1:28+i_z) = messag(1:i_z)
          mesdes(28+1:28+i_z) = messag(1:i_z)
          mesdes(28+1+i_z-3:28+i_z) = '...'
        else
          mesdes(28+1:28+ldes) = messag(1:ldes)
        endif
        DO i = 28+1, 28+ldes
          if (mesdes(i:i).eq.' ') mesdes(i:i) = '_'
        ENDDO
      ENDIF
      ldes = LONG(mesdes)
      m=1
      SEGINI,mtable
      i_z = 0
      b_z = .FALSE.
      r_z = 0.D0
      char_z = 'ENTIER          '
      typobj = 'MOT     '
      CALL ECCTAB(mtable,char_z(1:8),m  ,r_z,char_z        ,b_z,i_z,
     &                   typobj     ,i_z,r_z,mesdes(1:ldes),b_z,i_z)
      if (ierr.ne.0) return
      typobj = 'TABLE   '
      CALL ECROBJ(typobj,mtable)
      char_z = 'NCLK            '
      CALL ECRCHA(char_z(1:4))
      r_z = 1.D0
      CALL ECRREE(r_z)
      char_z = 'YGRA            '
      call ECRCHA(char_z(1:4))
      r_z = 1.D0
      CALL ECRREE(r_z)
      char_z = 'XGRA            '
      call ECRCHA(char_z(1:4))
      r_z = 1.D0
      CALL ECRREE(r_z)
      r_z = 0.D0
      CALL ECRREE(r_z)
      char_z = 'YBOR            '
      call ECRCHA(char_z(1:4))
      r_z = 1.D0
      CALL ECRREE(r_z)
      r_z = 0.D0
      CALL ECRREE(r_z)
      char_z = 'XBOR            '
      call ECRCHA(char_z(1:4))
      typobj = 'EVOLUTIO'
      CALL ECROBJ(typobj,mevoll)
      if (ierr.ne.0) return
      CALL DESSIN
      if (ierr.ne.0) return
 
C Etat initial des cases a cocher :
      choi2 = '        '
C La premiere case
      choi2(1:lcase) = 'Ok    '
C Les autres cases correspondent aux logiques
      DO i = 1, nbr
        j = i * lcase
        if (vale(i)) then
          choi2(j+1:j+lcase) = oui//' '//choix(i)(1:llong)
        else
          choi2(j+1:j+lcase) = non//' '//choix(i)(1:llong)
        endif
      ENDDO
 
      ncou = 16
      CALL TRINIT(25,DIOCAD,DIOCAD,TITREE,0.15,.TRUE.,ncou)
      CALL TRCLIK(1)
 
C Boucle d'analyse des cochages/decochages de cases :
  30  CONTINUE
        CALL MENU(choi2,ncase,lcase)
        CALL TRMESS(messag(1:lmes))
        icle = 0
        CALL TRAFF(icle)
        irep = icle+1
        if (irep.eq.1) GOTO 50
        i = irep - 1
        vale(i) = .NOT. vale(i)
        j = i * lcase
        if (vale(i)) then
          choi2(j+1:j+3) = oui
        else
          choi2(j+1:j+3) = non
        endif
      GOTO 30
 
  50  CONTINUE
 
C Recopie des valeurs :
      DO i = nblu, 1, -1
        CALL ECRLOG(vale(ipla(i)))
      ENDDO
 
C Menage des segments de travail :
      IF (mtable.NE.0) THEN
        SEGSUP,mtable,kevoll,mevoll,mlree1,mlree2
      ENDIF
 
c      RETURN
      END