*-----------------------------------------------------------------------
*     USER SUPPLIED FUNCTION (SAMPLE: additional map projections)
*-----------------------------------------------------------------------
*     Copyright (C) 2000-2016 GFD Dennou Club. All rights reserved.
*-----------------------------------------------------------------------
*
*     An original transformation can be defined by the user
*     when the following entries are provided:
*
*         STFUSR(UX,UY,XX,YY)    The forward transformation
*         STIUSR(XX,XY,UX,UY)    The inverse transformation
*         STSUSR                 Initialization of functions
*
*-----------------------------------------------------------------------
      SUBROUTINE STFUSR(XLON, YLAT, X, Y)

        INTEGER JPROJ
        CHARACTER CTTL*(*)
        LOGICAL LDEG
        PARAMETER (NCYC = 100)
        PARAMETER (NCYA = 101)
        PARAMETER (NCYB = 102)
        PARAMETER (NGLB = 103)
        PARAMETER (NCCT = 104)
        EXTERNAL RFPI
        DATA JPROJ /-1/
        SAVE JPROJ

        IF (JPROJ .EQ. NCYC) THEN
          CALL MPFCYC(XLON, YLAT, X, Y)
        ELSEIF (JPROJ .EQ. NCYA) THEN
          CALL MPFCYA(XLON, YLAT, X, Y)
        ELSEIF (JPROJ .EQ. NCYB) THEN
          CALL MPFCYB(XLON, YLAT, X, Y)
        ELSEIF (JPROJ .EQ. NGLB) THEN
          CALL MPFGLB(XLON, YLAT, X, Y)
        ELSEIF (JPROJ .EQ. NCCT) THEN
          CALL MPFCCT(XLON, YLAT, X, Y)
        ELSE
          WRITE(*, *) 'CALL STNUSR(i) before calling STFUSR'
          STOP 16
        ENDIF
      RETURN

*-----------------------------------------------------------------------
      ENTRY STIUSR(X, Y, XLON, YLAT)
        IF (JPROJ .EQ. NCYC) THEN
          CALL MPICYC(X, Y, XLON, YLAT)
        ELSEIF (JPROJ .EQ. NCYA) THEN
          CALL MPICYA(X, Y, XLON, YLAT)
        ELSEIF (JPROJ .EQ. NCYB) THEN
          CALL MPICYB(X, Y, XLON, YLAT)
        ELSEIF (JPROJ .EQ. NGLB) THEN
          CALL MPIGLB(X, Y, XLON, YLAT)
        ELSEIF (JPROJ .EQ. NCCT) THEN
          CALL MPICCT(X, Y, XLON, YLAT)
        ELSE
          WRITE(*, *) 'CALL STNUSR(i) before calling STIUSR'
          STOP 16
        ENDIF
      RETURN

*-----------------------------------------------------------------------
      ENTRY STSUSR
        CALL SGLGET('LDEG', LDEG)
        IF (LDEG) THEN
          CP = RFPI()/180
        ELSE
          CP = 1
        ENDIF
        ITR = 99

        CALL SGQVPT(VXMIN, VXMAX, VYMIN, VYMAX)

        CALL SGQSIM(SIMFAC, VXOFF, VYOFF)
        CALL SGQMPL(PLX, PLY, PLROT)

        VX0 = (VXMAX + VXMIN)/2 + VXOFF
        VY0 = (VYMAX + VYMIN)/2 + VYOFF

        CALL STSRAD(LDEG, LDEG)
        CALL STSROT(RFPI()/2 - CP*PLY, CP*PLX, CP*PLROT)
        CALL STSTRF(.TRUE.)
*       CALL STSTRN(ITR, SIMFAC, SIMFAC, VX0, VY0)
        CALL STSTRI(ITR)
        CALL STSTRP(SIMFAC, SIMFAC, VX0, VY0)

*       / SET CLIPPING REGION /

        CALL SGQTXY(TXMIN, TXMAX, TYMIN, TYMAX)
        CALL SZSCLX(CP*TXMIN, CP*TXMAX)
        CALL SZSCLY(CP*TYMIN, CP*TYMAX)

*       / SATELITE VIEW /

        CALL SGRGET('RSAT',RSAT)
        CALL MPSOTG(RSAT)

*       / SET STANDARD LATITUDE /

        CALL SGRGET('STLAT1',STLAT1)
        CALL SGRGET('STLAT2',STLAT2)

*       / JPROJ-DRIVEN CONFIG /
        IF (JPROJ .EQ. NCYB) THEN
          CALL MPSCYB(CP * STLAT1)
        ELSEIF (JPROJ .EQ. NCCT) THEN
          CALL MPSCCT(CP * STLAT1)
        ENDIF
      RETURN

*-----------------------------------------------------------------------
      ENTRY STNUSR(KPROJ)
        JPROJ = KPROJ
      RETURN

*-----------------------------------------------------------------------
      ENTRY STCUSR(I, CTTL)
        IF (I .EQ. NCYC) THEN
          CTTL = 'CENTRAL CYLINDRICAL'
        ELSEIF (I .EQ. NCYA) THEN
          CTTL = 'EQ.-AREA CYLINDRICAL'
        ELSEIF (I .EQ. NCYB) THEN
          CTTL = 'BRAUN CYLINDRICAL'
        ELSEIF (I .EQ. NGLB) THEN
          CTTL = 'BACON''S GLOBULAR'
        ELSEIF (I .EQ. NCCT) THEN
          CTTL = 'CENTRAL CONICAL'
        ELSE
          CTTL = ' '
        ENDIF
      RETURN

      END
