*-----------------------------------------------------------------------
*     Copyright (C) 2000-2022 GFD Dennou Club. All rights reserved.
*-----------------------------------------------------------------------
      PROGRAM SYSFONT

      PARAMETER (N=10)
      DIMENSION Y(N)
      CHARACTER FONTNAME*50, CH*3, OPT*20, FULLNAME*70
      INTEGER PM, J, NFNT

      CALL SWLSET('LSYSFNT', .TRUE.)

      CALL SWFTNM(NFNT)

      WRITE(*,*) ' WORKSTATION ID (I)  ? ;'
      CALL SGPWSN
      READ(*,*) IWS

      I = 0
      CALL ZGFONTNAME(I, FONTNAME, NFNT)

      PM = NFNT/N + 1

      OPT = ' Regular '

      WRITE(*,*) OPT



      CALL SGOPN(IWS)

      CALL SLDIV('T',2,2)

      X1 = 0.01
      X2 = 0.99
      XC = 0.35

      DO 30 J=0, PM
      CALL SGFRM

      CALL SGSLNI(1)
      DO 10 I=1, N
        Y(I) = 0.09 * (11-I)
        CALL SGLNV(X1, Y(I)+0.05, X2, Y(I)+0.05)
  10  CONTINUE
      CALL SGLNV(X1, 0.05, X2, 0.05)

      CALL SGSTXC(-1)

      DO 20 I=1, N
      IF (I+J*N .GT. NFNT-1) THEN
        GO TO 40
      END IF

      CALL ZGFONTNAME(I+J*N, FONTNAME, NFNT)

      DO 5 K=1, 50
         IF (FONTNAME(K:K) == FONTNAME(50:50)) THEN
           FULLNAME = FONTNAME(1:K-1)//OPT
         GO TO 6
         END IF
   5  CONTINUE
   6  CONTINUE


      CALL SWCSET('FONTNAME', FULLNAME)

      CALL SGSTXS(0.015)
      CALL SGTXV(X1, Y(I)+0.015, FULLNAME)
      WRITE(CH,'(I3)') I+J*N
      CALL SGTXZV(X1, Y(I)+0.035, CH, 0.015, 0, -1, 1)
      CALL SGSTXS(0.05)
      CALL SGTXV(XC, Y(I), 'ABCabs012留硫粒')
      WRITE(*,*) FULLNAME


  20  CONTINUE



  30  CONTINUE

  40  CONTINUE



      CALL SGCLS

      END
