source: TOOLS/MOZAIC/src/POLY/u_graph.f90 @ 3328

MODULE u_graph
   !---------------------------------------------------------------------
   !- module d'interface graphique
   !---------------------------------------------------------------------
   USE poly_types
   IMPLICIT NONE
   !-
   INTEGER,SAVE :: wkid1 = 1,wkcx1 = 70,wktp1 = 1110,wkca1
   INTEGER,SAVE :: ulerr = 70
   !---------------------------------------------------------------------
CONTAINS
   !-
   SUBROUTINE g_deb   (vxmin,vxmax,vymin,vymax)
      !---------------------------------------------------------------------
      !- debut de graphique
      !---------------------------------------------------------------------
      REAL (kind=rp) :: vxmin,vxmax,vymin,vymax
      !-
      INTEGER :: pgnt,dcunit,dcdxp,dcdyp,ierr
      INTEGER,DIMENSION(13) :: iasf = (/ 1,1,1,1,1,1,1,1,1,1,1,1,1 /)
      REAL (kind=rp),DIMENSION(4) :: wkvp,sndc
      REAL (kind=rp) :: ddd,dcdxm,dcdym
      REAL (kind=rp) :: dcdx,dcdy,gx,gy
      REAL (kind=rp) :: xmi,xms,ymi,yms
      !---------------------------------------------------------------------
      !- extrema
      ddd = vxmax-vxmin; xmi = vxmin-0.1_rp*ddd; xms = vxmax+0.1_rp*ddd;
      ddd = vymax-vymin; ymi = vymin-0.1_rp*ddd; yms = vymax+0.1_rp*ddd;
      !- ouverture du fichier des messages d'erreur
      OPEN    (unit=ulerr,file='dphierr', &
         status='unknown',form='formatted')
      !- ouverture de gks
      CALL gopks   (ulerr,-1)
      !- obtention de la categorie du poste de travail
      CALL gqwkca  (wktp1,ierr,wkca1)
      !- ouverture du poste de travail
      CALL gopwk   (wkid1,wkcx1,wktp1)
      !- obtention de la surface maximale d'affichage
      CALL gqdsp   (wktp1,ierr,dcunit,dcdxm,dcdym,dcdxp,dcdyp)
      IF (dcunit == 1) THEN
         dcdxm = dcdxp; dcdym = dcdyp;
      END IF
      !- activation du poste de travail
      CALL gacwk   (wkid1)
      !- definition des fenetres et clotures
      pgnt = 1
      gx   = xms-xmi; gy   = yms-ymi;
      CALL gswn    (pgnt,xmi,xms,ymi,yms)
      sndc(1:4) = (/ 0._rp, MIN(1.,gx/gy), 0._rp, MIN(1.,gy/gx) /)
      CALL gsvp    (pgnt,sndc(1),sndc(2),sndc(3),sndc(4))
      dcdx = dcdxm*(1._rp-MIN(1._rp,(dcdym*gx)/(dcdxm*gy)))/2._rp
      dcdy = dcdym*(1._rp-MIN(1._rp,(dcdxm*gy)/(dcdym*gx)))/2._rp
      wkvp(1:4) = (/ dcdx, (dcdxm-dcdx), dcdy, (dcdym-dcdy) /)
      CALL gswkwn  (wkid1,sndc(1),sndc(2),sndc(3),sndc(4))
      CALL gswkvp  (wkid1,wkvp(1),wkvp(2),wkvp(3),wkvp(4))
      !- activation de la transformation de normalisation
      CALL gselnt  (pgnt)
      CALL gsvpip  (0,pgnt,1)
      CALL gsds    (wkid1,0,1)
      !- definition du type des attributs
      CALL gsasf   (iasf)
      !----------------------
   END SUBROUTINE g_deb
   !-
   SUBROUTINE g_fin
      !---------------------------------------------------------------------
      !- fin de graphique
      !---------------------------------------------------------------------
      !- desactivation et fermeture du poste de travail
      CALL gdawk   (wkid1)
      CALL gclwk   (wkid1)
      !- fermeture de gks
      CALL gclks
      !- fermeture du fichier des messages d'erreur
      CLOSE  (unit=ulerr)
      !----------------------
   END SUBROUTINE g_fin
   !-
   SUBROUTINE g_fix
      !---------------------------------------------------------------------
      !- fixation du graphique
      !---------------------------------------------------------------------
      INTEGER :: istat,ichnb
      REAL (kind=rp)   :: pxi,pyi
      !---------------------------------------------------------------------
      IF (wkca1.EQ.2) THEN
         CALL grqlc   (wkid1,1,istat,ichnb,pxi,pyi)
      END IF
      !----------------------
   END SUBROUTINE g_fix
   !-
   SUBROUTINE g_pln   (np,px,py,il,ic)
      !---------------------------------------------------------------------
      !- affichage de polyligne
      !---------------------------------------------------------------------
      INTEGER :: np,il,ic
      REAL (kind=rp), DIMENSION(*) :: px,py
      !---------------------------------------------------------------------
      CALL gsln    (il)
      CALL gsplci  (ic)
      CALL gpl     (np,px,py)
      !----------------------
   END SUBROUTINE g_pln
   !-
   SUBROUTINE g_pmk   (np,px,py,ip,ic)
      !---------------------------------------------------------------------
      !- affichage de polymarque
      !---------------------------------------------------------------------
      INTEGER :: np,ip,ic
      REAL (kind=rp), DIMENSION(*) :: px,py
      !---------------------------------------------------------------------
      !* call gsmksc  (1.)
      CALL gsmk    (ip)
      CALL gspmci  (ic)
      CALL gpm     (np,px,py)
      !----------------------
   END SUBROUTINE g_pmk
   !-
   SUBROUTINE g_pol   (nv,vx,vy,is,ic)
      !---------------------------------------------------------------------
      !- affichage de polygone
      !---------------------------------------------------------------------
      INTEGER :: nv,is,ic
      REAL (kind=rp), DIMENSION(*) :: vx,vy
      !---------------------------------------------------------------------
      CALL gsfais  (is)
      CALL gsfaci  (ic)
      CALL gfa     (nv,vx,vy)
      !----------------------
   END SUBROUTINE g_pol
   !--------------------
END MODULE u_graph