* PACKAGE DDIAG  !" 力学 診断 
*
*"  [HIS]  92/10/15(takepiro)
*
***********************************************************************
      SUBROUTINE DDIAG      !"  診断出力 
     I         ( GDU   , GDV   , GDW   , GDT   , 
     C           PRND  , RAYL  , 
     C           ALAT  , ARAD                     )
*
#ifdef SYS_IBMS
      INCLUDE   (ZCDIM)                      !" 格子点数, 波数
      INCLUDE   (ZCCOM)                      !" 標準物理定数
#else
#include        "zcdim.F"                    !" 格子点数, 波数
#include        "zccom.F"                    !" 標準物理定数
#endif
*
*   [INPUT]
      REAL       GDU   ( IDIM, JDIM, KMAX )  !" 西風  Ｕ
      REAL       GDV   ( IDIM, JDIM, KMAX )  !" 南風  Ｖ
      REAL       GDW   ( IDIM, JDIM, KMAX )  !" 鉛直風 Ｗ
      REAL       GDT   ( IDIM, JDIM, KMAX )  !" 温度  Ｔ
*
      REAL       RAYL                        !" レイリー数
      REAL       PRND                        !" プランドル数
*
      REAL       ALAT  ( JDIM )              !" 緯度
      REAL       ARAD  ( KMAX )              !" ｒレベル(整数)
*
*   [INTERNAL WORK]
      COMMON    /COMWRK /
     &           GDKE  , GDIE  , GDTE  , GDAM
*
      REAL       GDKE  ( IDIM, JDIM, KMAX )  !" 運動エネルギー
      REAL       GDIE  ( IDIM, JDIM, KMAX )  !" 内部エネルギー
      REAL       GDTE  ( IDIM, JDIM, KMAX )  !" 全エネルギー
      REAL       GDAM  ( IDIM, JDIM, KMAX )  !" 角運動量
*
      INTEGER    I,J,K

*    [INTERNAL ONCE]      
      LOGICAL    OFIRST
      DATA       OFIRST / .TRUE. /
      SAVE       OFIRST
*[ONCE]
      IF ( OFIRST ) THEN
         OFIRST = .FALSE.
         CALL DDIHRG
      ENDIF
*
*"         < 1. エネルギー，角運動量 >
*
      DO 1100 K = 1, KMAX
         DO 1100 I = 1, IMAX
            DO 1100 J = 1, JMAX
*
               GDKE ( I,J,K )
     &                = (   GDU( I,J,K )**2
     &                    + GDV( I,J,K )**2 
     &                    + GDW( I,J,K )**2   )/ 2.  
*
               GDIE ( I,J,K )
     &                = (   GDT( I,J,K )**2   )/ 2.
     &                  * PRND * RAYL
*
               GDTE ( I,J,K )
     &                = GDKE ( I,J,K ) + GDIE ( I,J,K )
*
               GDAM ( I,J,K )
     &                = GDU ( I,J,K ) 
     &                  * ARAD( K ) * COS( ALAT(J) )
*
 1100 CONTINUE
*
      CALL HISTIN ( GDKE  , 'KE'  )
      CALL HISTIN ( GDIE  , 'IE'  )
      CALL HISTIN ( GDTE  , 'TE'  )
      CALL HISTIN ( GDAM  , 'AM'  )
*
      RETURN
      END
***********************************************************************
      SUBROUTINE DDIHRG      !"  診断出力の登録 
*
*   [INTERNAL PARAM]
      INTEGER    ISTYPL
      DATA       ISTYPL / 1 /
*   [INTERNAL WORK]
      REAL       VMISS
*
      CALL GZDBGT ( 'MISS' , VMISS )
*
      CALL     HISTRG
     I       ( 'KE    ', 'kinetic energy      ' ,'J     ', 'ALEV',
     I           VMISS , VMISS , VMISS , VMISS , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'XYZ'   ,'(1PE12.3)' )
*
      CALL     HISTRG
     I       ( 'IE    ', 'internal energy      ' ,'J     ', 'ALEV',
     I           VMISS , VMISS , VMISS , VMISS , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'XYZ'   ,'(1PE12.3)' )
*
      CALL     HISTRG
     I       ( 'TE    ', 'total energy         ' ,'J     ', 'ALEV',
     I           VMISS , VMISS , VMISS , VMISS , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'XYZ'   ,'(1PE12.3)' )
*
      CALL     HISTRG
     I       ( 'AM   ', 'angular momentum      ' ,'m/s   ', 'ALEV',
     I           VMISS , VMISS , VMISS , VMISS , ISTYPL  ,
     I         'CON'   , '   ' , 0     , 0     , 'XYZ'   ,'(1PE12.3)' )
*
      RETURN
      END
***********************************************************************
      SUBROUTINE SPCTLD      !"  スペクトル診断 
     I         ( WDATA , HTTL  , KDIMD , NMO   )
*
#ifdef SYS_IBMS
      INCLUDE (ZCDIM)                        !" 格子点数, 波数
#else
#include      "zcdim.F"                      !" 格子点数, 波数
#endif
*
*   [INPUT]
      INTEGER    KDIMD
      REAL       WDATA ( NMDIM, KDIMD )
      CHARACTER  HTTL  *(*)
      INTEGER    NMO   ( 2, 0:MMAX, 0:LMAX ) !" スペクトルの添字順番
*
*   [INTERNAL WORK]
      REAL       WAMP  ( 0:NMAX, KMAX+1 )
      LOGICAL    ODIAG
      INTEGER    JFLDIA, NCOLS, ISTR, IEND, IINT
      INTEGER    K,L,M,N
*
      CALL QDIAGP
     O     ( ODIAG , JFLDIA, NCOLS,
     O       ISTR  , IEND  , IINT ,
     I       KDIMD                  )
*
      IF ( .NOT. ODIAG )       RETURN
*
      CALL RESET ( WAMP, (NMAX+1)*KDIMD )
*
      DO 2100 K = 1, KDIMD
         DO 2110 N = 0 , NMAX
            DO 2120 M = 0 , MMAX, MINT
               L = N - M
               IF ( ( L .GE. 0 ).AND.( L .LE. LMAX ) ) THEN
                  WAMP ( N,K ) = WAMP ( N,K )
     &                         + WDATA( NMO(1,M,L),K ) ** 2
     &                         + WDATA( NMO(2,M,L),K ) ** 2
               ENDIF
 2120      CONTINUE
 2110   CONTINUE
 2100 CONTINUE
*
      WRITE ( JFLDIA, * ) '@@@@@@@@@@@@< SPECTRAL AMPLITUDE ', HTTL,
     &                    '>@@@@@@@@@@@@@'
*
      DO 3100 K = 1, KDIMD
         CALL PRINTD
     I       ( JFLDIA, '(1PE12.4)', WAMP  ,
     I         1     , NMAX+1 , 1     , K    ,
     I         NMAX+1, KDIMD  , NCOLS         )
 3100 CONTINUE
*
      RETURN
      END
