Sources Esope | Cast3M

trgetc
C TRGETC    SOURCE    GOUNAND   16/06/23    21:15:13     8982           
        SUBROUTINE TRGETC ( NCOUL )
c  permet de choisir une couleur en cliquant
c  dessus dans la fenetre graphique
c  a l'appel ncoul contient le nombre de couleurs maxi
c  au retour ncoul contient la couleur choisie
 
      IMPLICIT INTEGER(I-N)
 
-INC PPARAM
-INC CCOPTIO
-inc TMNTAB
-INC CCTRACE
        REAL X ,Y ,Z
        integer         ncoul
        integer         imcoul
        INTEGER ISORT, IRESU
        real          rxpos,rypos,hmin
        character*20    tmpcar
*
        dimension X(2),Y(2),Z(2)
        imcoul = ncoul
        imcoul = max(imcoul,20)
        ISORT = 0
        IRESU = 0
        call ini(IRESU,ISORT,0,0,0,0.,0.,0.,0.)
        xz=0d0
        xd=10d0
        xv=20d0
        x(1)=4.
        X(2)=8.
        z(1)=0.
        z(2)=0.
*        write(6,*) ' ires iogra  ' , ires , iogra
        call dfenet(xz,xd,xz,xv,xz,xd,xz,xd,xz,xv,.false.)
        call insegt(1,ires)
*        write(6,*) ' ires ' , ires
        tmpcar = 'Couleur No '
        if( icosc.eq.1) then
          ico1=7
        else
          ico1=8
        endif
        do 20 iy=1 , imcoul
          write (tmpcar(13:14),FMT='(I2)') iy
          rxpos = 2.
          rypos = 1. + iy
          call chcoul (ico1)
          call trlabl(rxpos,rypos,0.,tmpcar,15,hmin)
          call chcoul (iy)
          rxpos = 4.
          Y(1)=rypos
          y(2)=rypos
          call polrl(2,X,Y,Z)
          Y(1)=rypos+0.2
          y(2)=rypos+0.2
          call polrl(2,X,Y,Z)
*          call trlabl(rxpos,rypos,0.,
*     >       'ABCDEFGHIJKLMNOPQRSTUVWXYZ',26,hmin)
20      continue
        call chcoul(0)
        call majseg(1,0,0,0,0)
 
        call trmess ('Clicker sur la couleur de votre choix.')
        call trdig  (rxpos,rypos,inouse)
        ncoul = int (rypos - 1)
        if (ncoul.lt.0) ncoul=0
        if (ncoul.gt.imcoul) ncoul=imcoul
*
        end