Sources Esope | Cast3M

choi
C CHOI      SOURCE    PV090527  24/06/14    21:15:01     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 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