SUBROUTINE WRITEOBA

!**** SUBROUTINE WRITEOBA - WRITE-OUT OF OBS. 

!        D. VASILJEVIC   ECMWF     20/01/1992

!     PURPOSE
!     -------

!        WRITE-OUT OF CMA ARRAY

!**   INTERFACE
!     ---------

!        CALL WRITEOBA

!        WRITEOBA IS CALLED FROM SUBROUTINE CVA1 ETC.

!     METHOD
!     ------

!     EXTERNALS
!     ---------

!**   MODIFICATIONS
!     -------------

!        M. HAMRUD       16/09/95 : NEW CMA FORMAT
!        H. JARVINEN     20/09/95 : NEW CMA-FILE FORMAT
!        S. Saarinen     14/11/97 : Support for the new CMA I/O-library
!        S. Saarinen      4/11/98 : Explicit CMA flp validity check added
!        D.Dent          00-09-01 : MPE to MPL conversion
!        S. Saarinen     02/02/2001 : CCMA can now be created if LSCREEN

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

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK

USE YOMLUN   , ONLY : NULOUT   ,NULERR
USE YOMCMDDR
USE YOMCT0   , ONLY : NPROC    ,LSCREEN
USE YOMCT0B  , ONLY : LECMWF
USE YOMDB
USE YOMANA   , ONLY : NANDAT, NANTIM
USE YOMCMA   , ONLY : NRESUPD

IMPLICIT NONE

INTEGER(KIND=JPIM) :: J
INTEGER(KIND=JPIM) :: imxupd
INTEGER(KIND=JPIM) ::   ienv
INTEGER(KIND=JPIM) :: itslots, ileft_margin, iright_margin, ignore_tsl
character(len=20) ::  clenv
CHARACTER(LEN=64) ::  CLNAME
character(len=20) ::  CL_dbname
logical, save :: LLflpcheck = .FALSE.
logical, save :: LLfirst_time = .TRUE.
LOGICAL   :: LLSAVE, LLSWAPOUT
INTEGER(KIND=JPIM) :: inproca, inprocb, iWTMETHOD, inpes_ccma
logical :: LLWTINDEP, LLWTREMAP
REAL(KIND=JPRB) :: ZHOOK_HANDLE

INTERFACE
#include "getdb.h"
#include "putdb.h"
#include "abortdb.h"
#include "closedb.h"
#include "swapoutdb.h"
#include "revmatchupdb.h"
#include "shuffle_odb.h"
#include "storedb.h"
END INTERFACE

#include "openmp_obs.h"

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

!*       1.       INITIAL DEFINITIONS

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

CALL getenv('ODB_CMA', CL_dbname)
if (CL_dbname == ' ') then
  CALL ABOR1('WRITEOBA: Undefined ODB_CMA')
endif

!*          1.0   CLOSE OBS. FILE

!--ODB
LLSAVE = .TRUE.

!== fce-calc : do NOT update into the file <-- this is obsolete...
! if (LAVCGL .and. .NOT. (LANOBS)) LLSAVE = .FALSE.

1000 format(i20) ! 20 is the length of the clenv

if (LSCREEN) then
!-- Create CCMA directly while in Screening & ECMA is still 
!   (partially perhaps) in memory

  CALL ec_getenv('ODB_CCMA_CREATE_DIRECT', clenv)
  ienv = 0
  if (clenv /= ' ') read(clenv,1000) ienv

  if (ienv == 1) then
!--   Do create CCMA

    CALL ec_getenv('ODB_CCMA_TSLOTS', clenv)
    itslots = 1
    if (clenv /= ' ') read(clenv,1000) itslots
    
    CALL ec_getenv('ODB_CCMA_IGNORE_TSLOTS', clenv)
    ignore_tsl = 0
    if (clenv /= ' ') read(clenv,1000) ignore_tsl
    if (ignore_tsl /= 0) itslots = -abs(itslots)
    
    CALL ec_getenv('ODB_CCMA_LEFT_MARGIN', clenv)
    ileft_margin = 0
    if (clenv /= ' ') read(clenv,1000) ileft_margin
    
    CALL ec_getenv('ODB_CCMA_RIGHT_MARGIN', clenv)
    iright_margin = 0
    if (clenv /= ' ') read(clenv,1000) iright_margin

    CALL ec_getenv('ODB_CCMA_WTMETHOD', clenv)
    iwtmethod = 407 ! Changed from 107 for CY33R1/CY32R4 on 7/11/2007 by SS 
    if (clenv /= ' ') read(clenv,1000) iwtmethod
    
    CALL ec_getenv('ODB_CCMA_OBS_RANDOMIZE', clenv)
    LLWTREMAP = (clenv == '1')

    CALL ec_getenv('NPES_CCMA', clenv)
    inpes_ccma = 0
    if (clenv /= ' ') read(clenv,1000) inpes_ccma

    !-- When NPES_CCMA is set, then that number of pools will be created
    !   for CCMA.
    !   This allows to run traj0 will less MPI-tasks, and more OpenMP-threads 
    !   (say 2X less & more, respectively)

    if (inpes_ccma > 0) then
      inproca = inpes_ccma
      inprocb = 1
    else
      CALL ec_getenv('NPROCA', clenv)
      inproca = NPROC
      if (clenv /= ' ') read(clenv,1000) inproca
      
      CALL ec_getenv('NPROCB', clenv)
      inprocb = 1
      if (clenv /= ' ') read(clenv,1000) inprocb
    endif
    
    CALL GSTATS(1792,0)
    CALL STOREDB(-1) ! Save ECMA (whatever was still in memory; all pools)
    CALL GSTATS(1792,1)

    LLSAVE    = .TRUE.
    LLSWAPOUT = .TRUE.
    imxupd = NRESUPD
    LLWTINDEP = (mod(iwtmethod,100) == 7) ! "7" stands for NSATEM number (hist.reasons)

    CALL SHUFFLE_ODB(NULOUT, 'ECMA', 'CCMA', &
     & LLSAVE, LLSWAPOUT, &
     & NANDAT, NANTIM, imxupd, &
     & ileft_margin, iright_margin, &
     & itslots, &
     & inproca, inprocb, &
     & iWTMETHOD, LLWTINDEP, LLWTREMAP, .TRUE.) !*AF last argument is true because run from IFS

  endif
elseif (LECMWF .and. CL_dbname == 'ECMA') then ! must be in the last trajectory
!*AF Add revmatchup in the last trajectory if ECMWF...
   CALL getenv('ODB_REVMATCHUP_DIRECT', clenv)
   ienv = 0
   if (clenv /= ' ') read(clenv,*) ienv

   if (ienv == 1) then ! perform incore revmatchup (update CCMA)
     write(0,*) 'Last trajectory revmatchup' ! remove printouts after debug...
     CALL GSTATS(1775,0)
     CALL revmatchupdb(-1)
     CALL GSTATS(1775,1)
   endif

endif! if (LSCREEN) then ...

!-- Always SAVE DB (unless database opened as READONLY ;-) by S.Saarinen 12/03/2003
CLNAME='*'

CALL GSTATS(1792,0)
CALL SWAPOUTDB(CLNAME,-1,.TRUE.)
CALL CLOSEDB(LLSAVE)  
CALL GSTATS(1792,1)
WRITE(NULOUT,'('' *** WRITEOBA; DB IS CLOSED '')')
CALL FLUSH(NULOUT)

!     ------------------------------------------------------------------
IF (LHOOK) CALL DR_HOOK('WRITEOBA',1,ZHOOK_HANDLE)
END SUBROUTINE WRITEOBA

