SUBROUTINE SUSTADLR

! SUSTADLR:
!  Does diagnostics on standard atmosphere, for Wood and Staniforth deep-layer
!   equations:
!  In particuliar, we want to compare:
!  - "presim" with "prehyd" for a standard profile, in order to have an idea
!    of the departure "presim-prehyd", especially at the bottom.
!  - the radius, for a standard profile, and compare G(r-a) with the
!    standard atmosphere geopotential height.
!  Additionally, stores log(presim/prehyd) for a standard profile.

! Purpose
! -------
!   See above, and also comments in GNHDLR. 

! Interface
! ---------

! Externals
! ---------

! Method
! ------

! Reference
! ---------
!        ECMWF Research Department documentation of the IFS
!        ARPEGE documentation (IDEUL)
!        Wood and Staniforth, 2003 (in QJRMS)

! Author
! ------
!   K. Yessad (METEO-FRANCE/CNRM/GMAP). March 2008 

! Modifications
! -------------
!  K. Yessad (March 2009): fix a bug for LRWSDLG=T
! End Modifications
!---------------------------------------------------------------------

USE PARKIND1 , ONLY : JPIM     ,JPRB

USE YOMCT0   , ONLY : NPRINTLEV,LALLOPR
USE YOMLUN   , ONLY : NULOUT
USE YOMGEM   , ONLY : TOPPRES
USE YOMDYNA  , ONLY : LRWSDLR  ,LRWSDLG
USE YOMDYN   , ONLY : RCORPDF  ,RCORPDH
USE YOMDIM   , ONLY : NFLEVG
USE YOMSTA   , ONLY : STPRE    ,STPREH   ,STZ
USE YOMCST   , ONLY : RA
USE PAR_RDLR , ONLY : JP_DIMR  ,JP_RSAF  ,JP_RSAH  ,JP_ASRF  ,JP_ASRH

USE YOMHOOK  , ONLY : LHOOK    ,DR_HOOK

! -----------------------------------------------------------------------------

IMPLICIT NONE

! -----------------------------------------------------------------------------

INTEGER(KIND=JPIM) :: JLEV

REAL(KIND=JPRB) :: ZHOOK_HANDLE

REAL(KIND=JPRB) :: ZSTPDEP(1,NFLEVG)
REAL(KIND=JPRB) :: ZSTSP(1)
REAL(KIND=JPRB) :: ZSTPRESIMH(0:NFLEVG),ZSTPREHYDH(0:NFLEVG)
REAL(KIND=JPRB) :: ZSTPRESIMF(NFLEVG),ZSTPREHYDF(NFLEVG)
REAL(KIND=JPRB) :: ZSTZF(NFLEVG),ZSTZH(0:NFLEVG)
REAL(KIND=JPRB) :: ZRDLR(1,0:NFLEVG,JP_DIMR)

! -----------------------------------------------------------------------------

#include "abor1.intfb.h"
#include "susta_conv_prhs.intfb.h"

! -----------------------------------------------------------------------------

IF (LHOOK) CALL DR_HOOK('SUSTADLR',0,ZHOOK_HANDLE)

! -----------------------------------------------------------------------------

IF (.NOT.LRWSDLR) CALL ABOR1(' SUSTADLR should not be called if LRWSDLR=F!')

! * compute standard pressures.
ZSTPDEP(1,1:NFLEVG)=0.0_JPRB
ZSTSP(1)=LOG(STPREH(NFLEVG))
CALL SUSTA_CONV_PRHS(ZSTPDEP,ZSTSP,ZRDLR, &
 & ZSTPREHYDF,ZSTPREHYDH,ZSTPRESIMF,ZSTPRESIMH)

! * allocate and fill RCORPDF and RCORPDH.
ALLOCATE(RCORPDF(NFLEVG))
IF(NPRINTLEV >= 1.OR.LALLOPR) &
 & WRITE(NULOUT,9) 'RCORPDF  ',SIZE(RCORPDF),SHAPE(RCORPDF)
DO JLEV=1,NFLEVG
  RCORPDF(JLEV)=LOG(ZSTPRESIMF(JLEV)/ZSTPREHYDF(JLEV))
ENDDO
ALLOCATE(RCORPDH(0:NFLEVG))
IF(NPRINTLEV >= 1.OR.LALLOPR) &
 & WRITE(NULOUT,9) 'RCORPDH  ',SIZE(RCORPDH),SHAPE(RCORPDH)
DO JLEV=1,NFLEVG
  RCORPDH(JLEV)=LOG(ZSTPRESIMH(JLEV)/ZSTPREHYDH(JLEV))
ENDDO
IF (ZSTPREHYDH(0) < TOPPRES) THEN
  IF (LRWSDLG) THEN
    RCORPDH(0)=4._JPRB*LOG(ZRDLR(1,0,JP_RSAH))
  ELSE
    RCORPDH(0)=2._JPRB*LOG(ZRDLR(1,0,JP_RSAH))
  ENDIF
ELSE
  RCORPDH(0)=LOG(ZSTPRESIMH(0)/ZSTPREHYDH(0))
ENDIF

! * compute "Gz".
DO JLEV=1,NFLEVG
  ZSTZF(JLEV)=RA*(ZRDLR(1,JLEV,JP_RSAF)-1.0_JPRB)
ENDDO
DO JLEV=0,NFLEVG
  ZSTZH(JLEV)=RA*(ZRDLR(1,JLEV,JP_RSAH)-1.0_JPRB)
ENDDO

! * printings.
IF (NPRINTLEV >= 1) THEN

  WRITE(NULOUT,*)
  WRITE(NULOUT,FMT='('' SUSTADLR OUTPUT '')')
  WRITE(NULOUT,*)

  WRITE(NULOUT,FMT='('' FULL LEVELS '')')
  WRITE(NULOUT,FMT='(1X,''JLEV'',1X,&
   & 1X,''    STPRE    '',&
   & 1X,''  REC PREHYD '',&
   & 1X,''  MVC PRESIM '',&
   & 1X,''    HEIGHT   '',&
   & 1X,''    (r-a)    '')')
  DO JLEV=1,NFLEVG
    WRITE(UNIT=NULOUT,FMT='(1X,I3,2X,5(1X,F13.4))')&
     & JLEV,STPRE(JLEV),ZSTPREHYDF(JLEV),ZSTPRESIMF(JLEV),STZ(JLEV),ZSTZF(JLEV)
  ENDDO
  WRITE(NULOUT,*)

  WRITE(NULOUT,FMT='('' HALF LEVELS '')')
  WRITE(NULOUT,FMT='(1X,''JLEV'',1X,&
   & 1X,''    STPREH   '',&
   & 1X,''  REC PREHYD '',&
   & 1X,''  MVC PRESIM '',&
   & 1X,''    (r-a)    '')')
  DO JLEV=0,NFLEVG
    WRITE(UNIT=NULOUT,FMT='(1X,I3,2X,4(1X,F13.4))')&
     & JLEV,STPREH(JLEV),ZSTPREHYDH(JLEV),ZSTPRESIMH(JLEV),ZSTZH(JLEV)
  ENDDO
  WRITE(NULOUT,*)
  WRITE(NULOUT,'(A,F13.4,A,F13.4)') ' STPREH(NFLEVG)=',STPREH(NFLEVG), &
   & ' ,MVC PRESIM SURF=',ZSTPRESIMH(NFLEVG)
  WRITE(NULOUT,*)

  WRITE(NULOUT,FMT='('' (r/a) AND (a/r) '')')
  WRITE(NULOUT,FMT='(1X,''JLEV'',1X,&
   & 1X,'' (r/a) full lev '',&
   & 1X,'' (r/a) half lev '',&
   & 1X,'' (a/r) full lev '',&
   & 1X,'' (a/r) half lev '')')
  DO JLEV=1,NFLEVG
    WRITE(UNIT=NULOUT,FMT='(1X,I3,2X,4(1X,F16.10))') JLEV, &
     & ZRDLR(1,JLEV,JP_RSAF),ZRDLR(1,JLEV,JP_RSAH), &
     & ZRDLR(1,JLEV,JP_ASRF),ZRDLR(1,JLEV,JP_ASRH)
  ENDDO
  WRITE(NULOUT,*)

ENDIF

! -----------------------------------------------------------------------------
9 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8)

IF (LHOOK) CALL DR_HOOK('SUSTADLR',1,ZHOOK_HANDLE)

END SUBROUTINE SUSTADLR

