* PACKAGE USPST   !" 球面調和関数変換の準備
*
*"  [HIS] 90/08/31(numaguti)
*
**********************************************************************
      SUBROUTINE SETPNM      !" ルジャンドル関数の計算
     O         ( PNM   , DPNM  , NMO   ,
     I           QSINLA,
     D           JMAX  , MMAX  , LMAX  , NMAX  , MINT  , 
     D           NMDIM , JMXHF ,
     W           QPNM  , QDPNM                                  )
*
*   [PARAM] 
      INTEGER    JMAX
      INTEGER    MMAX
      INTEGER    LMAX
      INTEGER    NMAX
      INTEGER    MINT
      INTEGER    NMDIM
      INTEGER    JMXHF
*
*   [OUTPUT]       
      REAL       PNM   ( NMDIM, JMXHF )      !" ルジャンドル関数
      REAL       DPNM  ( NMDIM, JMXHF )      !" Ｐnm μ微分
      INTEGER    NMO   ( 2, 0:MMAX, 0:LMAX ) !" スペクトルの添字順番
*
*   [INPUT] 
      REAL * 8   QSINLA( JMAX )              !" sin（緯度）：倍精度
*
*   [WORK] 
      REAL * 8   QPNM  ( 0:NMAX+1, 0:MMAX )  !" Ｐnm ルジャンドル
      REAL * 8   QDPNM ( 0:NMAX+1, 0:MMAX )  !" Ｐnm μ微分
*
*   [INTERNAL WORK] 
      INTEGER    J, L, M, LEND, MEND, NMH
*
*
      DO 3300 J = 1, JMAX/2
*"                                               ------ J loop -----
*
*"         < 1. ルジャンドル関数の計算 >
*
         CALL LGNDRE
     I         ( QSINLA(J), MMAX  , NMAX,
     O           QPNM     , QDPNM                )
*
*"         < 2. 配列の順番 l-wise >
*"                           ------  zonal mean model の場合注意！
         NMH  = 0
         DO 2200 L = 0, LMAX
            MEND = MIN( MMAX, NMAX-L )
            DO 2100 M = 0, MEND, MINT
               NMH = NMH + 1
               IF ( MMAX .EQ. 0 ) THEN
                  NMO ( 1, M, L ) = NMH
                  NMO ( 2, M, L ) = NMH
               ELSE
                  NMO ( 1, M, L ) = 2* NMH - 1
                  NMO ( 2, M, L ) = 2* NMH
               ENDIF
 2100       CONTINUE
 2200    CONTINUE
*
*"         < 3. ルジャンドル関数の詰め替え >
*
         DO 3200 M = 0, MMAX, MINT
            LEND = MIN( LMAX, NMAX-M )
            DO 3100 L = 0, LEND
               PNM  (  NMO( 1,M,L ),J  ) =   QPNM ( L+M,M )
               PNM  (  NMO( 2,M,L ),J  ) =   QPNM ( L+M,M )
               DPNM (  NMO( 1,M,L ),J  ) = - QDPNM( L+M,M )
               DPNM (  NMO( 2,M,L ),J  ) = - QDPNM( L+M,M )
 3100       CONTINUE
 3200    CONTINUE
*
*"                                               ------ J loop -----
 3300 CONTINUE
*
      RETURN
      END
**********************************************************************
      SUBROUTINE LGNDRE               !" ルジャンドル関数の計算
     I         ( CTHETA , MMAX  , NMAX,
     O           QPNM   , QDPNM                )
*
*   [PARAM] 
      INTEGER    NMAX
      INTEGER    MMAX
*
*   [INPUT] 
      REAL * 8   CTHETA                      !" μ=sin(緯度)
*
*   [OUTPUT] 
      REAL * 8   QPNM  ( 0:NMAX+1, 0:MMAX )  !" Ｐnm ルジャンドル
      REAL * 8   QDPNM ( 0:NMAX+1, 0:MMAX )  !" Ｐnm μ微分
*
*   [INTERNAL WORK] 
      INTEGER    M, N
      REAL * 8   STHETA, EPS, EPSM, EPSP
*      
*
*"         < 1. ( １−μ＾2 )^1/2  >
*
      STHETA = SQRT ( 1.D0 - CTHETA **2 )
*
*"         < 2. P_m^m P_m+1^m を求める >
*
      DO 2100 M = 0, MMAX
*
          IF ( M .EQ. 0 ) THEN
             QPNM ( 0, 0 ) = 1.  
          ELSE
             QPNM ( M ,M ) = QPNM ( M-1,M-1 )
     &                        * SQRT(  DBLE( 2*M+1 )/ DBLE( 2*M )  )
     &                        * STHETA
          ENDIF
*
          QPNM ( M+1,M ) = QPNM ( M,M )
     &                     * SQRT( DBLE( 2*M+3 ) ) * CTHETA
*
 2100 CONTINUE
*
*"         < 3. P_n^m を漸化式で求める >
*
      DO 3100 M = 0, MMAX
         DO 3100 N = M+2, NMAX+1
*
            EPS         = SQRT (   ( DBLE( N   )**2 - DBLE( M )**2 )
     &                           / ( 4.D0 * DBLE( N   )**2 - 1.D0  )  )
            EPSM        = SQRT (   ( DBLE( N-1 )**2 - DBLE( M )**2 )
     &                           / ( 4.D0 * DBLE( N-1 )**2 - 1.D0  )  )
*
            QPNM( N,M ) = (   QPNM ( N-1,M ) * CTHETA
     &                      - QPNM ( N-2,M ) * EPSM    ) / EPS
*
 3100 CONTINUE
*
*"         < 4. d/dy P_n^m  を漸化式で求める >
*
      DO 4100 M = 0, MMAX
*
         EPS           = SQRT (   ( DBLE( M+1 )**2 - DBLE( M )**2 )
     &                         / ( 4.D0 * DBLE( M+1 )**2 - 1.D0  )  )
         QDPNM ( M,M ) = QPNM ( M+1,M ) * DBLE( M ) * EPS
*
         DO 4200 N = M+1, NMAX
            EPS          = SQRT (   ( DBLE( N   )**2 - DBLE( M )**2 )
     &                            / ( 4.D0 * DBLE( N   )**2 - 1.D0  )  )
            EPSP         = SQRT (   ( DBLE( N+1 )**2 - DBLE( M )**2 )
     &                            / ( 4.D0 * DBLE( N+1 )**2 - 1.D0  )  )
*
            QDPNM( N,M ) =   QPNM ( N+1,M ) * DBLE( N   ) * EPSP
     &                     - QPNM ( N-1,M ) * DBLE( N+1 ) * EPS
*
 4200    CONTINUE
 4100 CONTINUE
*
      RETURN
      END
**********************************************************************
      SUBROUTINE GAUSS      !"  ガウス緯度・荷重の計算 
     O         ( CTHETA , GW     ,
     I           JMAX             )
*
*   [PARAM] 
      INTEGER    JMAX
*
*   [OUTPUT] 
      REAL * 8   CTHETA( JMAX )              !" sin(緯度)＝μ
      REAL * 8   GW    ( JMAX )              !" ガウス荷重
*
*   [INTERNAL PARM] 
      REAL * 8   DELTP
      REAL * 8   DELTPD
      REAL * 8   DELTPS
      DATA       DELTPD / 1.0 D-28 /         !' ４倍精度の収束条件
      DATA       DELTPS / 1.0 D-14 /         !'   倍精度の収束条件
      INTEGER    ITRMAX
      DATA       ITRMAX / 50 /               !" 繰り返し最大値
*
*   [INTERNAL WORK] 
      INTEGER    JMAXD
      PARAMETER (JMAXD=200)
      REAL * 8   QPN( 0:JMAXD+1 )            !" Ｐn (倍精度)
      INTEGER    N, J, ITER
      REAL * 8   PI, X0, DELTX, R, RP
      REAL * 8   EPS, EPSM, EPSP, QDPN
*
      IF ( JMAX .GT. JMAXD) THEN
         CALL MSGDMP( 'E','GAUSS','INSUFFICIENT WORK STRAGE.')
      ENDIF
*
*"         < 0. AUTODBL 指定チェック：ちょっとトリッキー >
*
      R  = 1.
      RP = R + DELTPD
      WRITE ( 6,* ) ' precision check .. ', RP
*
      IF ( RP .GT. R ) THEN
         WRITE ( 6,* ) ' REAL*16 is used in GAUSS'
         DELTP = DELTPD
      ELSE
         WRITE ( 6,* ) ' only REAL*8 is used in GAUSS'
         DELTP = DELTPS
      ENDIF
*
      PI = ATAN( 1.D0 ) * 4.D0
*
      DO 5100 J = 1 , JMAX/2
*
*"         < 1. 初期推定値 >
*
         X0 = COS (  ( DBLE( J ) - 0.5D0  )/ DBLE( JMAX ) * PI   )
*
         DO 4100 ITER = 1, ITRMAX
*
*"         < 2. Pn を求める >
*
            QPN   ( 0 ) = 1.D0
            QPN   ( 1 ) = SQRT( 3.D0  ) * X0
*
            DO 2100 N = 2, JMAX+1
               EPS       = SQRT (   ( DBLE( N   )**2                )
     &                            / ( 4.D0 * DBLE( N   )**2 - 1.D0  )  )
               EPSM      = SQRT (   ( DBLE( N-1 )**2                )
     &                            / ( 4.D0 * DBLE( N-1 )**2 - 1.D0  )  )
*
               QPN ( N ) = (   QPN  ( N-1 ) * X0
     &                        - QPN  ( N-2 ) * EPSM    ) / EPS
 2100       CONTINUE
*
*"         < 3. d/dμ Pn を求める >
*
            EPS       = SQRT (   ( DBLE( JMAX   )**2                  )
     &                         / ( 4.D0 * DBLE( JMAX   )**2 - 1.D0 )  )
            EPSP      = SQRT (   ( DBLE( JMAX+1 )**2                  )
     &                         / ( 4.D0 * DBLE( JMAX+1 )**2 - 1.D0 )  )
*
            QDPN      =   QPN  ( JMAX+1 ) * DBLE( JMAX   ) * EPSP
     &                  - QPN  ( JMAX-1 ) * DBLE( JMAX+1 ) * EPS
*
*"         < 4. Newton 法でゼロ点を求める >
*
            DELTX = QPN ( JMAX ) / QDPN * ( 1.0D0 - X0 **2 )
            X0    = X0 + DELTX
*
            IF ( ABS( DELTX ) .LT. DELTP ) GOTO 4200
*"                                             >---- exit ----->
 4100    CONTINUE
         WRITE ( 6,* ) ' error in GAUSS(4) ', DELTX
*
*"                                             <---- exit -----<
 4200    CONTINUE
*
         CTHETA ( J ) = X0
*
*"         < 5. ガウス荷重 >
*
         GW     ( J ) =    ( DBLE( 2*JMAX ) - 1.0D0  )
     &                   * ( 1.0D0  - X0 **2 )
     &                   / (   DBLE( JMAX ) * QPN ( JMAX-1 )  )**2
*
 5100 CONTINUE
*
      DO 6100 J = 1, JMAX/2
         GW     ( JMAX-J+1 ) =   GW     ( J )
         CTHETA ( JMAX-J+1 ) = - CTHETA ( J )
 6100 CONTINUE
*
      RETURN
      END
