* PACKAGE DG2WD  !" 力学 格子→スペクトル
*
*"  [HIS] 90/08/31(numaguti)
*"        92/05/18(masaaki)       VOR,DIV(LMAX=0) の取扱い変更
*
**********************************************************************
      SUBROUTINE TENG2W         !" 時間変化項 ( スペクトル化 )
     O         ( WTVOR , WTDIV , WTT   , WTPI  , WTQ   ,
     I           GTUA  , GTVA  , GTKE  , GTUT  , GTVT  , GTH   ,
     I           GTPI  , GTUQ  , GTVQ  , GTR   ,
     C           FLAPLA                                          )
*
*   [PARAM] 
#ifdef SYS_IBMS
      INCLUDE   (ZCDIM)
#else
#include        "zcdim.F"
#endif
*
*   [OUTPUT]
      REAL       WTVOR ( NMDIM, KMAX      )  !" 渦度  ζ 時間変化
      REAL       WTDIV ( NMDIM, KMAX      )  !" 発散  Ｄ 時間変化
      REAL       WTT   ( NMDIM, KMAX      )  !" 温度  Ｔ 時間変化
      REAL       WTPI  ( NMDIM            )  !" logPs π 時間変化
      REAL       WTQ   ( NMDIM, KMAX      )  !" 比湿  ｑ 時間変化
*
*   [INPUT]
      REAL       GTUA  ( IDIM, JDIM, KMAX )  !" 東西運動量移流項ＵＡ
      REAL       GTVA  ( IDIM, JDIM, KMAX )  !" 南北運動量移流項ＶＡ
      REAL       GTKE  ( IDIM, JDIM, KMAX )  !" 運動エネルギー項ＫＥ
      REAL       GTUT  ( IDIM, JDIM, KMAX )  !" 温度東西移流項  ＵＴ
      REAL       GTVT  ( IDIM, JDIM, KMAX )  !" 温度南北移流項  ＶＴ
      REAL       GTH   ( IDIM, JDIM, KMAX )  !" 温度時間変化項  Ｈ
      REAL       GTPI  ( IDIM, JDIM       )  !" 気圧時間変化項  Ｚ
      REAL       GTUQ  ( IDIM, JDIM, KMAX )  !" 比湿東西移流項  Ｕｑ
      REAL       GTVQ  ( IDIM, JDIM, KMAX )  !" 比湿南北移流項  Ｖｑ
      REAL       GTR   ( IDIM, JDIM, KMAX )  !" 比湿時間変化項  Ｒ
*
      REAL       FLAPLA( NMDIM )             !" ラプラシアンの係数
*
*   [INTERNAL WORK]
      COMMON    /COMWRK/
     &           GDUU  , GDVV
      REAL       GDUU  ( IDIM*JDIM, KMAX )   !" 西風  Ｕ
      REAL       GDVV  ( IDIM*JDIM, KMAX )   !" 南風  Ｖ
      EQUIVALENCE (GDUU, WTKE)
      REAL       WTKE  ( NMDIM     , KMAX )  !" 運動エネルギー項 ＫＥ
*
      INTEGER    K, NM
*
*"         < 1.  渦度 ζ  >
*
*
*"      ( - ∂(ＵＡ)/∂ｙ )
*
      CALL G2W
     O         ( WTVOR ,
     I           GTUA  ,
     I           'YGRA', 'POS ',  KMAX  )
*
*"      (  ∂(ＶＡ)/∂ｘ )
*
      IF ( MMAX .GE. 1 ) THEN
         CALL G2W
     O         ( WTVOR ,
     I           GTVA  ,
     I           'XGRA', 'ADD ', KMAX  )
      ENDIF
*
*"         < 2.  発散 Ｄ  >
*
*"      (  ∂(ＶＡ)/∂ｙ )
*
      CALL G2W
     O         ( WTDIV ,
     I           GTVA  ,
     I           'YGRA', 'NEG ', KMAX )
*
*"      (  ∂(ＵＡ)/∂ｘ )
*
      IF ( MMAX .GE. 1 ) THEN
         CALL G2W
     O         ( WTDIV ,
     I           GTUA  ,
     I           'XGRA', 'ADD ', KMAX )
      ENDIF
*
*"      ( ＫＥ )
*
      CALL G2W
     O         ( WTKE  ,
     I           GTKE  ,
     I           '    ', 'POSO', KMAX )
*
      DO 2000 K = 1 , KMAX
         DO 2000 NM = 1 , NMDIM
*
*"      ( - ∇・∇ Ｅ )
*
            WTDIV ( NM, K ) =  WTDIV ( NM, K )
     &                          - FLAPLA( NM ) * WTKE( NM, K )
*
 2000 CONTINUE
*
*"         < 3. 温度 Ｔ >
*
*"      ( Ｈ )
*
      CALL G2W
     O         ( WTT   ,
     I           GTH   ,
     I           '    ', 'POSO', KMAX )
*
*"      ( - ∂(ＶＴ')/∂ｙ )
*
      IF ( LMAX .GE. 1 ) THEN
         CALL G2W
     O         ( WTT   ,
     I           GTVT  ,
     I           'YGRD', 'ADD ', KMAX )
      ENDIF
*
*"      ( - ∂(ＵＴ')/∂ｘ )
*
      IF ( MMAX .GE. 1 ) THEN
         CALL G2W
     O         ( WTT   ,
     I           GTUT  ,
     I           'XGRD', 'SUB ', KMAX )
      ENDIF
*
*"         < 4. 地表面気圧 π >
*
*"      ( Ｚ )
*
      CALL G2W
     O         ( WTPI  ,
     I           GTPI  ,
     I           '    ', 'POSO',  1  )
*
*
*"         < 5. 比湿 ｑ >
*
*"      ( Ｒ )
*
      CALL G2W
     O         ( WTQ   ,
     I           GTR   ,
     I           '    ', 'POSO', KMAX )
*
*"      ( - ∂(Ｖｑ)/∂ｙ )
*
      IF ( LMAX .GE. 1 ) THEN
         CALL G2W
     O         ( WTQ   ,
     I           GTVQ  ,
     I           'YGRD', 'ADD ', KMAX  )
      ENDIF
*
*"      ( - ∂(Ｕｑ)/∂ｘ )
*
      IF ( MMAX .GE. 1 ) THEN
         CALL G2W
     O         ( WTQ   ,
     I           GTUQ  ,
     I           'XGRD', 'SUB ', KMAX )
      ENDIF
*
      RETURN
      END
***********************************************************************
      SUBROUTINE GD2WD     !" 予報変数 ( スペクトル化 )
     O         ( WDVOR , WDDIV , WDT   , WDPI  , WDQ   ,
     I           GDVOR , GDDIV , GDT   , GDPS  , GDQ    )
*
*   [PARAM] 
#ifdef SYS_IBMS
      INCLUDE   (ZCDIM)
#else
#include        "zcdim.F"
#endif
*
*   [OUTPUT]
      REAL       WDVOR ( NMDIM , KMAX     )  !" 渦度  ζ
      REAL       WDDIV ( NMDIM , KMAX     )  !" 発散  Ｄ
      REAL       WDT   ( NMDIM , KMAX     )  !" 温度  Ｔ
      REAL       WDPI  ( NMDIM            )  !" log Ps ＝π
      REAL       WDQ   ( NMDIM , KMAX     )  !" 比湿  ｑ
*
*   [INPUT]
      REAL       GDVOR ( IDIM*JDIM, KMAX )   !" 渦度  ζ
      REAL       GDDIV ( IDIM*JDIM, KMAX )   !" 発散  Ｄ
      REAL       GDT   ( IDIM*JDIM, KMAX )   !" 温度  Ｔ
      REAL       GDPS  ( IDIM*JDIM       )   !" 地表気圧 Ｐｓ
      REAL       GDQ   ( IDIM*JDIM, KMAX )   !" 比湿  ｑ
*
*   [INTERNAL WORK]
* g77 が文句をいわないようにするため,
* サブルーチン GUV2DV と COMWRK の大きさを同じにしている
      COMMON    /COMWRK/
     &           GDUU  , GDVV
      EQUIVALENCE (GDUU, GDPI)
      REAL       GDUU  ( IDIM*JDIM, KMAX )   !" 西風  Ｕ
      REAL       GDVV  ( IDIM*JDIM, KMAX )   !" 南風  Ｖ
      REAL       GDPI  ( IDIM*JDIM       )   !" log Ps ＝π
*
      INTEGER    IJ
*
*"         < 1. 予報変数 ζ,Ｄ,Ｔ, π,ｑ の変換 >
*
      CALL G2W
     O         ( WDVOR ,
     I           GDVOR ,
     I           '    ', 'POS ', KMAX )
*
      CALL G2W
     O         ( WDDIV ,
     I           GDDIV ,
     I           '    ', 'POS ', KMAX )
*
      CALL G2W
     O         ( WDT   ,
     I           GDT   ,
     I           '    ', 'POSO', KMAX )
*
      DO 1300 IJ = 1, IDIM*JDIM
         GDPI ( IJ ) = LOG ( GDPS( IJ ) )
 1300 CONTINUE
*
      CALL G2W
     O         ( WDPI  ,
     I           GDPI  ,
     I           '    ', 'POSO', 1    )
*
      CALL G2W
     O         ( WDQ   ,
     I           GDQ   ,
     I           '    ', 'POSO', KMAX )
*
      RETURN
      END
***********************************************************************
      SUBROUTINE GUV2VD    !" （Ｕ,Ｖ）格子点 → （ζ,Ｄ） スペクトル
     O         ( WDVOR , WDDIV ,
     I           GDU   , GDV   ,
     C           UVFACT         )
*
*   [PARAM] 
#ifdef SYS_IBMS
      INCLUDE    (ZCDIM)
#else
#include         "zcdim.F"
#endif
*
*   [OUTPUT]
      REAL       WDVOR ( NMDIM , KMAX     )  !" 渦度  ζ
      REAL       WDDIV ( NMDIM , KMAX     )  !" 発散  Ｄ
*
*   [INPUT]
      REAL       GDU   ( IDIM*JDIM, KMAX )   !" 西風  ｕ
      REAL       GDV   ( IDIM*JDIM, KMAX )   !" 南風  ｖ
      REAL       UVFACT( IDIM*JDIM )         !" u→U のファクター
*
*   [INTERNAL WORK]
* g77 が文句をいわないようにするため,
* サブルーチン GUV2DV と COMWRK の大きさを同じにしている
      COMMON    /COMWRK/
     &           GDUU  , GDVV
      REAL       GDUU  ( IDIM*JDIM, KMAX )   !" 西風  Ｕ
      REAL       GDVV  ( IDIM*JDIM, KMAX )   !" 南風  Ｖ
*
      INTEGER    IJ, K
*
*"         < 1. ζ のスペクトル >
*
      DO 1100 K = 1, KMAX
         DO 1100 IJ = 1, IDIM*JDIM
            GDUU ( IJ, K ) = GDU ( IJ, K ) * UVFACT( IJ )
            GDVV ( IJ, K ) = GDV ( IJ, K ) * UVFACT( IJ )
 1100 CONTINUE
*
      CALL G2W
     O         ( WDVOR ,
     I           GDUU  ,
     I           'YGRA', 'POS ', KMAX )
*
      IF ( MMAX .GE. 1 ) THEN
         CALL G2W
     O         ( WDVOR ,
     I           GDVV  ,
     I           'XGRA', 'ADD ', KMAX )
      ENDIF
*
*"         < 2. Ｄ のスペクトル >
*
      CALL G2W
     O         ( WDDIV ,
     I           GDVV  ,
     F           'YGRA', 'NEG ', KMAX )
*
      IF ( MMAX .GE. 1 ) THEN
         CALL G2W
     O         ( WDDIV ,
     I           GDUU  ,
     F           'XGRA', 'ADD ', KMAX )
      ENDIF
*
      RETURN
      END
