SUBROUTINE WRCOE

!**** * WRCOE  * - ROUTINE TO WRITE THE COUPLED FIELDS

!     PURPOSE.
!     --------
!        WRITES YOMGCO ON DISK (distributed memory version)

!**   INTERFACE.
!     ----------
!        *CALL* *WRCOE*

!     EXPLICIT ARGUMENTS :  NONE
!     --------------------

!     IMPLICIT ARGUMENTS :
!     --------------------
!        COMMON  YOMGCO

!     METHOD.
!     -------
!        Depends on NOACOMM

!     EXTERNALS.
!     ----------

!     REFERENCE.
!     ----------
!        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS

!     AUTHOR.
!     -------
!        CHRISTINE DREVETON

!     MODIFICATIONS.
!     --------------
!        ORIGINAL : 92-05-25 (D'APRES WRFU)
!        MODIFIED : 92-06-15 (reset to zero)
!                   92-10-12 by M. Deque (signal for coupling)
!                   93-12-01 modified by L. Terray (compatibility with C90)
!                   95-02-14 T. Stockdale (scaling of fields, u/f write)
!                   95-10-11 T. Stockdale (proper unit numbers for pipes)
!                   96-02-22 T. Stockdale (dimension of write statement, for SL)
!                   96-03-20 G. Mozdzynski(support distributed memory)
!                   98-07-20 T. Stockdale (merge of wrcoesm and wrcoe)
!                   99-12-28 R. El Khatib (remove poles rows)
!                   00-07-14 T. Stockdale (bugfix for calls to message passing)
!                   00-08-18 T. Stockdale (bugfix for previous bugfix)
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!-----------------------------------------------------------------------

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

USE YOMLUN   , ONLY : NCMAFL   ,NULCO    ,NULOUT
USE YOMCOU   , ONLY : NCULF
USE YOMMCC   , ONLY :    NOACOMM
USE YOMMSC   , ONLY : NINTLEN  ,NREALEN
USE YOMDIM   , ONLY : NDGLG    ,NDLON
USE YOMGCO   , ONLY : STRSU    ,STRSV    ,FCHAS    ,FRSOS    ,FHUMS
USE YOMDYN   , ONLY : TSTEP
USE YOMGEM   , ONLY :    NGPTOTG  ,NGPTOTMX ,NGPTOT
USE YOMCT0   , ONLY : NFRCO
USE YOMCT3   , ONLY : NSTEP
USE YOMMP    , ONLY : MYPROC

IMPLICIT NONE

INTEGER(KIND=JPIM) :: JPNCHP

PARAMETER(JPNCHP=6)
REAL(KIND=JPRB) :: ZHEAT (NGPTOTG)
REAL(KIND=JPRB) :: ZFCHAS(NGPTOTG)
REAL(KIND=JPRB) :: ZFRSOS(NGPTOTG)
REAL(KIND=JPRB) :: ZSTRSU(NGPTOTG)
REAL(KIND=JPRB) :: ZSTRSV(NGPTOTG)
REAL(KIND=JPRB) :: ZFHUMS(NGPTOTG)
REAL(KIND=JPRB) :: ZREAL(NDLON*NDGLG)
REAL(KIND=JPRB) :: ZWORK(NGPTOTMX)
REAL(KIND=JPRB) :: ZFACT
INTEGER(KIND=JPIM) :: ICSTEP

INTEGER(KIND=JPIM) :: IA, IRET, ISND, ISST1,&
 & ISST2, ISTEP, JL ,J  

LOGICAL :: LLDONE
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"
#include "orcvgpf.intfb.h"
#include "osndgpf.intfb.h"
#include "sugco0.intfb.h"

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

!*       1.    PREPARATIONS.
!              --------------
!   WRCOE is called from end of CNT4, so different timekeeping

IF (LHOOK) CALL DR_HOOK('WRCOE',0,ZHOOK_HANDLE)
ISTEP=NSTEP
IF(ISTEP <= 0) THEN
  WRITE(NULOUT,*) 'ERROR: WRCOE CALLED AT WRONG TIMESTEP'
  WRITE(NULOUT,*) 'NSTEP IS ',NSTEP
  IF (LHOOK) CALL DR_HOOK('WRCOE',1,ZHOOK_HANDLE)
  RETURN
ENDIF

!*       1.2   OPEN FILES

ISND=1

DO J=1,NGPTOT
  ZWORK(J)=FCHAS(J,1)
ENDDO
CALL OSNDGPF(FCHAS(1,1),ISND)
IF( MYPROC == ISND )THEN
  CALL ORCVGPF(ZFCHAS,ZWORK)
ENDIF
DO J=1,NGPTOT
  ZWORK(J)=FRSOS(J,1)
ENDDO
CALL OSNDGPF(FRSOS(1,1),ISND)
IF( MYPROC == ISND )THEN
  CALL ORCVGPF(ZFRSOS,ZWORK)
ENDIF
DO J=1,NGPTOT
  ZWORK(J)=STRSU(J)
ENDDO
CALL OSNDGPF(STRSU,ISND)
IF( MYPROC == ISND )THEN
  CALL ORCVGPF(ZSTRSU,ZWORK)
ENDIF
DO J=1,NGPTOT
  ZWORK(J)=STRSV(J)
ENDDO
CALL OSNDGPF(STRSV,ISND)
IF( MYPROC == ISND )THEN
  CALL ORCVGPF(ZSTRSV,ZWORK)
ENDIF
DO J=1,NGPTOT
  ZWORK(J)=FHUMS(J,1)
ENDDO
CALL OSNDGPF(FHUMS(1,1),ISND)
IF( MYPROC == ISND )THEN
  CALL ORCVGPF(ZFHUMS,ZWORK)
ENDIF

IF( MYPROC == ISND )THEN

  ZFACT=1.0_JPRB/(NFRCO*TSTEP)
  DO JL=1,NGPTOTG
    ZHEAT(JL) =(ZFCHAS(JL)+ZFRSOS(JL))*ZFACT
    ZFRSOS(JL)=ZFRSOS(JL)*ZFACT
    ZSTRSU(JL)=ZSTRSU(JL)*ZFACT
    ZSTRSV(JL)=ZSTRSV(JL)*ZFACT
    ZFHUMS(JL)=ZFHUMS(JL)*ZFACT
  ENDDO

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

!*       2.   WRITE OUT SURFACE FLUXES
!             ------------------------

  ZREAL(:)=0.0_JPRB

  IF((NOACOMM <= 2).OR.(NOACOMM == 4)) THEN
    OPEN(UNIT=NULCO,FILE='flxatmos',FORM='UNFORMATTED',POSITION='REWIND')
  ENDIF

  DO JL=1,NGPTOTG
    ZREAL(JL)=ZHEAT(JL)
  ENDDO
  IF((NOACOMM <= 2).OR.(NOACOMM == 4)) THEN
    WRITE(NULCO) 'QNET_ATM'
    WRITE(NULCO) ZREAL
  ELSEIF(NOACOMM == 3) THEN
    CALL SVIPC_WRITE(NCULF(3),ZREAL,NDLON*NDGLG*NREALEN,IRET)
  ENDIF

  DO JL=1,NGPTOTG
    ZREAL(JL)=ZFRSOS(JL)
  ENDDO
  IF((NOACOMM <= 2).OR.(NOACOMM == 4)) THEN
    WRITE(NULCO) 'QSOL_ATM'
    WRITE(NULCO) ZREAL
  ELSEIF(NOACOMM == 3) THEN
    CALL SVIPC_WRITE(NCULF(4),ZREAL,NDLON*NDGLG*NREALEN,IRET)
  ENDIF

  DO JL=1,NGPTOTG
    ZREAL(JL)=ZSTRSU(JL)
  ENDDO
  IF((NOACOMM <= 2).OR.(NOACOMM == 4)) THEN
    WRITE(NULCO) 'TAUX_ATM'
    WRITE(NULCO) ZREAL
  ELSEIF(NOACOMM == 3) THEN
    CALL SVIPC_WRITE(NCULF(5),ZREAL,NDLON*NDGLG*NREALEN,IRET)
  ENDIF

  DO JL=1,NGPTOTG
    ZREAL(JL)=ZSTRSV(JL)
  ENDDO
  IF((NOACOMM <= 2).OR.(NOACOMM == 4)) THEN
    WRITE(NULCO) 'TAUY_ATM'
    WRITE(NULCO) ZREAL
  ELSEIF(NOACOMM == 3) THEN
    CALL SVIPC_WRITE(NCULF(6),ZREAL,NDLON*NDGLG*NREALEN,IRET)
  ENDIF

  DO JL=1,NGPTOTG
    ZREAL(JL)=ZFHUMS(JL)
  ENDDO
  IF((NOACOMM <= 2).OR.(NOACOMM == 4)) THEN
    WRITE(NULCO) 'PMEV_ATM'
    WRITE(NULCO) ZREAL
  ELSEIF(NOACOMM == 3) THEN
    CALL SVIPC_WRITE(NCULF(7),ZREAL,NDLON*NDGLG*NREALEN,IRET)
  ENDIF

  IF((NOACOMM <= 2).OR.(NOACOMM == 4)) THEN
    CLOSE(NULCO)
  ENDIF

  WRITE(NULOUT,*) 'SURFACE FLUXES WRITTEN TO COUPLING FILES'

  IF(NOACOMM == 1) THEN
    WRITE(NCMAFL(5),*) ISTEP
    CALL FLUSH(NCMAFL(5))
    WRITE(NCMAFL(6),*) ISTEP
    CALL FLUSH(NCMAFL(6))
    WRITE(NCMAFL(7),*) ISTEP
    CALL FLUSH(NCMAFL(7))
    WRITE(NCMAFL(8),*) ISTEP
    CALL FLUSH(NCMAFL(8))
    WRITE(NCMAFL(9),*) ISTEP
    CALL FLUSH(NCMAFL(9))
    WRITE(NULOUT,*) 'OASIS SIGNALLED VIA PIPES'
  ELSEIF((NOACOMM == 2).OR.(NOACOMM == 4)) THEN
    CALL PBWRITE(NCULF(3),ISTEP,NINTLEN,IRET)
    CALL PBFLUSH(NCULF(3))
    CALL PBWRITE(NCULF(4),ISTEP,NINTLEN,IRET)
    CALL PBFLUSH(NCULF(4))
    CALL PBWRITE(NCULF(5),ISTEP,NINTLEN,IRET)
    CALL PBFLUSH(NCULF(5))
    CALL PBWRITE(NCULF(6),ISTEP,NINTLEN,IRET)
    CALL PBFLUSH(NCULF(6))
    CALL PBWRITE(NCULF(7),ISTEP,NINTLEN,IRET)
    CALL PBFLUSH(NCULF(7))
    WRITE(NULOUT,*) 'OASIS SIGNALLED VIA PIPES'
  ENDIF

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

!*       3.    WAIT UNTIL SST FIELDS READY 
!              ---------------------------
!  (Needs modifiying for last timestep of serial runs)

  IF(NOACOMM == 1) THEN
    CALL FLUSH(NULOUT)
    READ(NCMAFL(3),*) ICSTEP
    READ(NCMAFL(4),*) ICSTEP
  ELSEIF(NOACOMM == 2) THEN
    CALL FLUSH(NULOUT)
    CALL PBREAD(NCULF(1),ICSTEP,NINTLEN,IRET)
    CALL PBREAD(NCULF(2),ICSTEP,NINTLEN,IRET)
  ELSEIF(NOACOMM == 3) THEN
!   Nothing to do - continue execution
  ELSEIF(NOACOMM == 4) THEN
    IA=0
    ISST1=0
    ISST2=0
    LLDONE=.FALSE.
    DO WHILE (.NOT.LLDONE)
      IF(ISST1 == 0) CALL PBREAD(NCULF(1),ICSTEP,NINTLEN,IRET)
      IF(IRET > 0) ISST1=1
      IF(ISST2 == 0) CALL PBREAD(NCULF(2),ICSTEP,NINTLEN,IRET)
      IF(IRET > 0) ISST2=1
      IF(ISST1*ISST2 == 0) THEN
        IA=IA+1
        IF(IA == 1) THEN
          WRITE(NULOUT,*) 'Sleeping ...'
          CALL FLUSH(NULOUT)
        ENDIF
        CALL SLEEP(1)
        IF(IA > 300) THEN
          WRITE(NULOUT,*) 'Timed out waiting for coupler'
          CALL ABOR1('ABORT in INICOU')
        ENDIF
      ELSE
        IF(IA /= 0) THEN
          WRITE(NULOUT,*) 'Slept for ',IA,' seconds'
        ENDIF
        LLDONE=.TRUE.
      ENDIF
    ENDDO
  ENDIF

  IF(NOACOMM /= 3) THEN
    WRITE(NULOUT,*) 'OASIS REPLIED THAT NEW SST FIELD IS READY'
    WRITE(NULOUT,*) 'OASIS ITERATION NUMBER ',ICSTEP
  ENDIF

ENDIF

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

!*       4.    RESET TO ZERO
!              -------------

!  At the next joint cycle, we should create a single SUGCO0
CALL SUGCO0

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

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