* PACKAGE DSETC  !" 力学 定数設定(水平差分)
*
*"  [HIS] 90/09/12(takepiro)
*"        93/07/12(takepiro) FLAPLA バグフィックス
*"        93/08/13(takepiro) SPSTUP への ER を 1 にする(半径 1 上の水平微分)
*
***********************************************************************
      SUBROUTINE DSETC     !"  力学パートの定数セット(水平差分)
     O         ( NMO   , FLAPLA, EDEL  , UVFACT, 
     C           ALAT  , DLAT                     )
*
*   [PARAM] 
#ifdef SYS_IBMS
      INCLUDE   (ZCDIM)                      !" 格子点数，波数
      INCLUDE   (ZCCOM)                      !" 標準物理定数
#else
#include        "zcdim.F"                    !" 格子点数，波数
#include        "zccom.F"                    !" 標準物理定数
#endif
*
*   [OUTPUT] 
      INTEGER    NMO   ( 2, 0:MMAX, 0:LMAX ) !" スペクトルの添字順番
      REAL       FLAPLA( NMDIM  )            !" ラプラシアンの係数
      REAL       EDEL  ( NMDIM  )            !" ζ，Ｄ→Ｕ，Ｖ
*"       : 球関数展開定数
*
      REAL       UVFACT ( IDIM, JDIM )       !" u→U のファクター
*"       : 力学定数
*
      REAL       ALAT  ( JDIM )              !" 緯度
      REAL       DLAT  ( JDIM )              !" 緯度荷重
*        : 座標格子定数
*
*   [INTERNAL WORK] 
      REAL * 8   QSINLA( JDIM )              !" sin（緯度）：倍精度
      REAL * 8   QGW   ( JDIM )              !" ガウス荷重 ：倍精度
*
      INTEGER    I, J
*
*"         < 1. 球面調和関数展開パラメーター >
*
      IF ( JMAX .GE. 2 ) THEN
         CALL GAUSS
     O         ( QSINLA, QGW   ,
     I           JMAX            )
      ELSE
         QSINLA( 1 ) = SIN ( ALAT( 1 ) )
         QGW   ( 1 ) = DLAT( 1 )
      ENDIF
*
      CALL SPSTUP
     I         ( QSINLA, QGW   , 1.0   ,
     O           NMO                    )
*
      CALL SETCOF
     O         ( FLAPLA, EDEL  ,
     I           1.0   , NMO     )
*
*"         < 2. U ファクター )
*
      DO 3200 I = 1, IDIM
         DO 3210 J = 1, JDIM
            UVFACT ( I,J ) = COS( ALAT( J ) )
 3210    CONTINUE
 3200 CONTINUE
*
      RETURN
      END
***********************************************************************
      SUBROUTINE SETCOF              !" スペクトル計算の係数
     O        ( FLAPLA, EDEL  ,
     I          ER    , NMO   )
*
*   [PARAM] 
#ifdef SYS_IBMS
      INCLUDE   (ZCDIM)                      !" 格子点数，波数
#else
#include        "zcdim.F"                    !" 格子点数，波数
#endif
*
*   [OUTPUT] 
      REAL       FLAPLA( NMDIM  )            !" ラプラシアンの係数
      REAL       EDEL  ( NMDIM  )            !" ζ,Ｄ→Ｕ,Ｖ
*
*   [INPUT] 
      REAL       ER                          !" 地球半径
      INTEGER    NMO   ( 2, 0:MMAX, 0:LMAX ) !" スペクトルの添字順番
*
*   [INTERNAL WORK] 
      INTEGER    L, M, LEND
      REAL       AN
*
*"         < 1. ラプラシアンとその変形 >
*
      DO 2110 M = 0 , MMAX, MINT
         LEND = MIN( LMAX, NMAX-M )
         DO 2100 L = 0 , LEND
            AN = L + M
            IF ( AN .GT. 0.1 ) THEN
               FLAPLA( NMO(1,M,L) )= - AN*( AN+1. ) 
               FLAPLA( NMO(2,M,L) )= - AN*( AN+1. ) 
               EDEL  ( NMO(1,M,L) )= - ER / ( AN *( AN+1. ) )
               EDEL  ( NMO(2,M,L) )= - ER / ( AN *( AN+1. ) )
            ENDIF
 2100    CONTINUE
 2110 CONTINUE
*
      FLAPLA( NMO(1,0,0) ) =  0.  
      FLAPLA( NMO(2,0,0) ) =  0.  
      IF ( LMAX .NE. 0 ) THEN
         EDEL  ( NMO(1,0,0) ) =  0.  
         EDEL  ( NMO(2,0,0) ) =  0.  
      ELSE
         EDEL  ( NMO(1,0,0) ) =  ER
         EDEL  ( NMO(2,0,0) ) =  0.  
      ENDIF
*
      RETURN
      END
