subroutine writesd (cdfile,cdtype)

!*** *WRITESD*

!   Purpose.
!   --------

!      To write gridpoint standard deviations of background, analysis
!      or forecast error

!   Interface.
!   ----------

!      CALL WRITEVEC (CDFILE)

!             where CDFILE  =  name of file to be written to
!                   CDTYPE  =  FDB type ('ef', 'eb', or 'ea')

!   Externals.
!   ----------

!   Reference.
!   ----------
!      None yet!

!   Author.
!   -------
!      Mike Fisher *ECMWF*

!   Modifications.
!   --------------
!      Original    95-11-23
!      L. Isaksen  96-05-05  Adapted for Message Passing
!      E. Holm     98-06-16  Ozone added
!      E. Andersson98-08-18  Radiance and tcw Bg errors
!      D.Dent      00-09-01  MPE to MPL conversion
!      M.Hamrud    02-01-10  Use PREGRBENC instead of MODNSEC
!      R. El Khatib : 01-08-07 Pruning options
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        M.Hamrud      10-Jan-2004 CY28R1 Cleaning
!        M.Hamrud      01-Dec-2005 Generalized IO scheme
!-----------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
USE YOMCT0   , ONLY : CTYPE
USE YOMCST   , ONLY : RG
USE YOMDIM   , ONLY : NFLEVG   ,NPROMA
USE YOMGRB   , ONLY : &
 & NGRBLNSP ,NGRBT    ,NGRBU    ,&
 & NGRBV    ,NGRBVO   ,NGRBGH   ,NGRBQ    ,NGRBBTMP  ,&
 & NGRBO3   ,NGRBTCWV ,NGRBR    ,NGRB10U  ,NGRB10V  ,&
 & NGRB2T   ,NGRBTCO3 ,NGRBGHG  ,NGRBGRG, NGRBAERLG
USE YOMGEM   , ONLY : NGPTOT
USE YOMOP    , ONLY : NFDBREF
USE YOMVAR   , ONLY : NOANEF   ,NFGFCLEN ,LBGM     ,LFDBERR
USE YOMANEB  , ONLY : NANEBU   ,NANEBV   ,NANEBZ   ,NANEBR ,&
 & NANEBQ   ,NANEBT   ,NANEBVO  ,NANEBO3  ,NANEBSP  ,ANEBUF   ,NANEBRAD ,NANEBTCW ,&
 & NANEBRH2 ,NANEBU10 ,NANEBV10 ,NANEBT2  ,NANEBTO3 ,&
 & NANERADS ,NANERADL ,NANEBGHG ,NANEBGRG, NANEBAERO
USE IOSTREAM_MIX , ONLY : SETUP_IOSTREAM, SETUP_IOREQUEST, IO_PUT, &
 & CLOSE_IOSTREAM, TYPE_IOSTREAM , TYPE_IOREQUEST, Y_IOSTREAM_FDB,&
 & CLOSE_IOREQUEST, FLUSH_IOSTREAM
USE FDBSUBS_MOD , ONLY : ISETVALFDBSUBS
USE YOM_YGFL, ONLY : JPGHG, JPGRG, NGHG, NGRG, YGHG, YGRG
USE YOMJG, ONLY : NAEROCV, JPAEROCV
IMPLICIT NONE

CHARACTER(LEN=*)  ,INTENT(IN)    :: CDFILE 
CHARACTER(LEN=2)  ,INTENT(IN)    :: CDTYPE 

REAL(KIND=JPRB)                  :: ZANE(NPROMA,NOANEF)
REAL(KIND=JPRB),    ALLOCATABLE  :: ZGGFLD(:,:,:)
INTEGER(KIND=JPIM), ALLOCATABLE  :: IGRIB2D(:),ILEVS2D(:)
CHARACTER (LEN = 2) :: CLTYPE
CHARACTER (LEN = 3) :: CLLEVT
CHARACTER (LEN = 4) :: CLSTEP

!--- order in which to write fields, to ensure a MARS retrieve from the
!--- FDB will fetch the fields in the same order as a MARS retrieve from
!--- the IBM.

INTEGER(KIND=JPIM), PARAMETER :: JPVARS=16+JPGHG+JPGRG+JPAEROCV
INTEGER(KIND=JPIM), DIMENSION(JPVARS) :: IOFF_L,ICODES
INTEGER(KIND=JPIM) :: IGRBGHG(JPGHG),IGRBGRG(JPGRG),IGRBAERO(JPAEROCV),JGHG,JGRG,JAERO
INTEGER(KIND=JPIM) :: IRET,IOFF,ILEVX,IGRCODE &
 & ,ISTC,IENDC,IKL,ISTEP,JVAR,JKGLO,JKG,JLEV  
LOGICAL :: LLRAD,LLSFC
TYPE(TYPE_IOSTREAM)  :: YL_IOSTREAM
TYPE(TYPE_IOREQUEST) :: YL_IOREQUEST
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "sc2rdg.intfb.h"

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

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

IGRBGHG(:)=-1
DO JGHG=1,NGHG
  IGRBGHG(JGHG)=YGHG(JGHG)%IGRBCODE
ENDDO
IGRBGRG(:)=-1
DO JGRG=1,NGRG
  IGRBGRG(JGRG)=YGRG(JGRG)%IGRBCODE
ENDDO
IGRBAERO(:)=-1
DO JAERO=1,NAEROCV
  IGRBAERO(JAERO)=NGRBAERLG
ENDDO

IOFF_L = (/NANEBSP,NANEBT,NANEBU,NANEBV,NANEBVO &
 & ,NANEBZ,NANEBQ,NANEBR,NANEBO3,NANEBTO3,NANEBRAD,NANEBTCW &
 & ,NANEBRH2,NANEBU10,NANEBV10,NANEBT2,NANEBGHG,NANEBGRG,NANEBAERO/)  
ICODES = (/NGRBLNSP,NGRBT,NGRBU,NGRBV,NGRBVO &
 & ,NGRBGH,NGRBQ,NGRBR,NGRBO3,NGRBTCO3,NGRBBTMP,NGRBTCWV &
 & ,NGRBR,NGRB10U,NGRB10V,NGRB2T,NGRBGHG,NGRBGRG&
 & ,NGRBAERLG/)  

ISTEP = 0
CLTYPE = CTYPE ! Preserve CTYPE
CTYPE  = CDTYPE
IF(CTYPE == 'ef') THEN
  ISTEP = NFGFCLEN
ELSEIF(CTYPE == 'eb') THEN
  CTYPE = 'ef'      ! TYPE eb IS NOT KNOWN TO FDB.
ELSE
  IF(LBGM) ISTEP = NFGFCLEN
ENDIF

!--- set up FDB parameters or open output file

if (LFDBERR) then
  CALL GSTATS(1713,0)
  IRET = ISETVALFDBSUBS (NFDBREF,'TYPE',CTYPE)
  IRET = ISETVALFDBSUBS (NFDBREF,'REPR','gg')
  WRITE (CLSTEP,'(I4.4)') ISTEP
  IRET = ISETVALFDBSUBS (NFDBREF,'STEP',clstep)
  CALL GSTATS(1713,1)
ELSE
  CALL SETUP_IOSTREAM(YL_IOSTREAM,'CIO',TRIM(CDFILE),CDMODE='w',KIOMASTER=1)
ENDIF

!--- Encode upper air and surface pressure fields in GRIB format

VARIABLE_LOOP : DO JVAR=1,JPVARS
  IOFF = IOFF_L(JVAR)
!--- Not allocated variables are characterized by negative offset.
  IF (IOFF < 0) CYCLE VARIABLE_LOOP

!--- Single level variables, ps and tcw.
  LLSFC = ANY(IOFF == (/NANEBTCW,NANEBTO3,NANEBRH2,NANEBU10,NANEBV10,NANEBT2/))
  LLRAD = IOFF == NANEBRAD

!--- Set number of levels/channels.
  IF(LLRAD .OR. LLSFC) THEN
    IF(LLSFC) THEN
      ILEVX = 1
    ELSE
      ILEVX = NANERADS
    ENDIF
    IF(LFDBERR) IRET = ISETVALFDBSUBS (NFDBREF,'LEVT','s')
    CLLEVT = 'SFC'
  ELSE
    IF(IOFF == NANEBSP) THEN
      ILEVX = 1
    ELSE
      ILEVX = NFLEVG
    ENDIF
    IF(LFDBERR) IRET = ISETVALFDBSUBS (NFDBREF,'LEVT','m')
    CLLEVT = 'ML '
  ENDIF
  ALLOCATE(IGRIB2D(ILEVX))
  ALLOCATE(ILEVS2D(ILEVX))
  ALLOCATE(ZGGFLD(NGPTOT,ILEVX,1))
  IGRCODE = ICODES(JVAR)
  IGRIB2D(:) = IGRCODE

  CALL GSTATS(1438,0)
!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) &
!$OMP& PRIVATE (JKGLO,ISTC,IENDC,JKG,IKL,ZANE,JLEV)
  DO JLEV=1,ILEVX
    IF(LLRAD) THEN
      ILEVS2D(JLEV) = NANERADL(JLEV)
    ELSE
      ILEVS2D(JLEV) = JLEV
    ENDIF
    MESSP_LOOP : DO JKGLO=1,NGPTOT,NPROMA
      ISTC  = 1
      IENDC = MIN(NPROMA,NGPTOT-JKGLO+1)
      CALL SC2RDG (ANEBUF,JKGLO,ISTC,IENDC,ZANE)
      DO JKG=JKGLO-1+ISTC,JKGLO-1+IENDC
        IKL = JKG-JKGLO+1
        ZGGFLD(JKG,JLEV,1) = SQRT(MAX(0.0_JPRB,ZANE(IKL,JLEV+IOFF)))
        IF (IGRCODE == NGRBGH)  ZGGFLD(JKG,JLEV,1) =  ZGGFLD(JKG,JLEV,1)/RG
      ENDDO
    ENDDO MESSP_LOOP
  ENDDO
!$OMP END PARALLEL DO
  CALL GSTATS(1438,1)
  CALL SETUP_IOREQUEST(YL_IOREQUEST,'GRIDPOINT_FIELDS',LDGRIB=.TRUE.,&
   & KGRIB2D=IGRIB2D,KLEVS2D=ILEVS2D,CDLEVTYPE=CLLEVT)
  IF(LFDBERR) THEN
    CALL IO_PUT(Y_IOSTREAM_FDB,YL_IOREQUEST,PR3=ZGGFLD)
  ELSE
    CALL IO_PUT(YL_IOSTREAM,YL_IOREQUEST,PR3=ZGGFLD)
  ENDIF
  CALL CLOSE_IOREQUEST(YL_IOREQUEST)
  DEALLOCATE(IGRIB2D)
  DEALLOCATE(ILEVS2D)
  DEALLOCATE(ZGGFLD)
ENDDO VARIABLE_LOOP

!--- close output file or reset FDB parameters

CTYPE = CLTYPE ! Restore CTYPE
IF (LFDBERR) THEN
  CALL GSTATS(1713,0)
  IRET = ISETVALFDBSUBS (NFDBREF,'TYPE',CTYPE(1:2))
  IRET = ISETVALFDBSUBS (NFDBREF,'CHANNEL','off')
  CALL FLUSH_IOSTREAM(Y_IOSTREAM_FDB)
  CALL GSTATS(1713,1)
ELSE
  CALL CLOSE_IOSTREAM(YL_IOSTREAM)
ENDIF

IF (LHOOK) CALL DR_HOOK('WRITESD',1,ZHOOK_HANDLE)
END SUBROUTINE WRITESD
