SUBROUTINE COUPLO4_EXCHANGE(KMODE)

!***** CUOPL04_EXCHANGE  *   PUT and GETS Transient field to OASIS4 Coupler!

!**   PURPOSE.
!     --------
!      This routine accesses local grid point fields from the ifs memory 
!      structure, (gmv, gfl gppbut) and put & gets them to/from 
!      the coupler oasis4  by the calls of routines from the psmile library.
!      The fields and grid are defined in ouplo4_definitions.f90 

!     The exchange is based on all local MPI_tasks
!     Additionally an option is implemented for exchange on one processor only 
!     The subroutine will be changed in order to permittransfer of 
!     single transient fields at different parts of the code 

!**   INTERFACE.
!     ----------
!              *COUPLEO4_exchange(KMODE) 
!               THE call of the exchange is split into two parts
!               KMODE = 1 (chemistry field before IFS physics)
!               KMODE = 2 (meterological fields after IFS physics)
!**   EXTERNALS 
!     ----------
!              *prism_put    
!              *PRISM_get
!              *PRISM_CALC_NEWDAT
!               GATH_GRID
!               DIST_GRID 
!               sc2rdg

!     REFERENCE.
!     ----------

!                   OASIS4 User guide
!     AUTHOR.
!     -------
!     2005-22-10  J. Flemming

!     MODIFICATIONS.
!     --------------


  USE COUPLO4_MIX  ,ONLY : YFIELD_CPL, YMODEL_TIME_BOUNDS, & 
   &        YMODEL_TIME, LGLOBALEXCHANGEGP, MEX_PROCGP, & 
   &        LGLOBALEXCHANGESP, MEX_PROCSP, NBR_FIELDS, EINCRMODEL, &
   &        RPREVACC  

!  USE COUPLO4_COM_MOD, ONLY : LGETCOMM_PRISM

  USE YOMCOUPLO4, ONLY :  CTM!, LDIA_GRG

  USE PARKIND1  ,ONLY : JPIM     ,JPRB

  USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK

  USE YOMLUN   , ONLY : NULERR

  USE YOMGEM   , ONLY : NGPTOTG, NGPTOT

  USE YOMDIM   , ONLY : NFLEVG   ,NPROMA, NSPEC2, NSPEC2G, &
       & NUMP, NSMAX,  NSPEC2MX,  NFLEVL, NGPBLKS
  USE YOMGFL   , ONLY : GFL

  USE YOMGMV   , ONLY : GMV, GMVS

  USE YOMMP    , ONLY : MYPROC, MYSETV, NPTRLL,  NPSP, NBSETLEV 

  USE YOMGC    , ONLY : GELAM  ,GELAT, OROG       
  
  USE YOMSP    , ONLY : SPVOR, SPDIV, SPSP

  USE YOMLAP   , ONLY : MYMS     

  USE SURFACE_FIELDS_MIX  , ONLY :SD_VD, SD_VF, SP_RR, SP_SB, SP_SG 

  USE YOMDYN   , ONLY : TSTEP

  USE YOMCT0   , ONLY : NPROC, LCOUPLO4

  USE PRISM_DUMMY_MOD

  USE MPL_MODULE , ONLY : MPL_SEND, MPL_RECV, MPL_BARRIER, MPL_GATHERV, JP_BLOCKING_STANDARD

! #ifdef TIMING
!  use PSMILe, only : comm_psmile
! #endif

  IMPLICIT NONE
! ARGUMENTS 

  INTEGER(KIND=JPIM),INTENT(IN)   :: KMODE 

! LOCAL FIELD  VARIABLES

!  REAL(KIND=JPRB),ALLOCATABLE :: ZGPP(:,:) 

  REAL (KIND=JPRB), ALLOCATABLE ::  ZLOCAL(:,:)
  REAL (KIND=JPRB), ALLOCATABLE ::  ZGLOBAL(:,:)
  REAL (KIND=JPRB), ALLOCATABLE ::  ZGLOBALSP(:,:)
  REAL (KIND=JPRB), ALLOCATABLE ::  ZGLOBALSP_T(:,:)
  REAL (KIND=JPRB), ALLOCATABLE ::  ZLOCGP(:,:,:)  

  INTEGER(KIND=JPIM) , ALLOCATABLE:: ITO(:) 
  INTEGER(KIND=JPIM) , ALLOCATABLE:: ISETV(:) 

  INTEGER(KIND=JPIM)            ::  IFGATHG
  INTEGER(KIND=JPIM) :: IERROR, I_ERRORS, INFO, IFLD, IGRID_TYP
  INTEGER(KIND=JPIM) :: ISTAF, I_I, I_K, I_IG,I_KG 
  INTEGER(KIND=JPIM) :: JSTGLO, ISTC, ICEND  
  INTEGER(KIND=JPIM) :: IBL, J, JLEV, INDEX, I
  INTEGER(KIND=JPIM) :: IM, JN, IC,  ILEVSP, JMLOC
  INTEGER(KIND=JPIM) :: IPROC, IOFFSET, INDEX_ACC

  LOGICAL          :: LLCALLPSMILE 
  LOGICAL          :: LLFIRST, LLAST

  REAL(KIND=JPRB)  :: ZPI      

  REAL(KIND=JPRB)  ::    ZNPSP(1)
  REAL (KIND=JPRB) ::    ZALLNPSP(NPROC)
  INTEGER (KIND=JPIM) :: IRECVCOUNTS(NPROC)  

  REAL(KIND=JPRB), SAVE  :: ZTIMECPL      
  
  REAL(KIND=JPRB) :: ZHOOK_HANDLE

  INTERFACE
#include "dist_grid.h"
#include "gath_grid.h"
#include "gath_spec.h"
  END INTERFACE

#include "abor1.intfb.h"
#include "couplo4_grg_input.intfb.h"

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

!---------------------------------------
! ACTION only if prism run
! ---------------------------------------
IF( .NOT. LCOUPLO4 )  THEN
    IF (LHOOK) CALL DR_HOOK('COUPLO4_EXCHANGE',1,ZHOOK_HANDLE)
   RETURN
ENDIF

!----------------------------------------------------------------------
!                   1.   TIME CHECK ans SETTINGS
! ----------------------------------------------------------------------
  LLFIRST=.FALSE.

  LLAST=.FALSE.  

  IF (  (YMODEL_TIME%SECOND == PRISM_JOBSTART_DATE%SECOND) .AND. &
       &    (YMODEL_TIME%MINUTE == PRISM_JOBSTART_DATE%MINUTE) .AND. &
       &    (YMODEL_TIME%HOUR   == PRISM_JOBSTART_DATE%HOUR  ) .AND. &
       &    (YMODEL_TIME%DAY    == PRISM_JOBSTART_DATE%DAY   ) .AND. &
       &    (YMODEL_TIME%MONTH  == PRISM_JOBSTART_DATE%MONTH ) .AND. &
       &    (YMODEL_TIME%YEAR   == PRISM_JOBSTART_DATE%YEAR  )) & 
       &     LLFIRST=.TRUE.

IF (  (      YMODEL_TIME%SECOND == PRISM_JOBEND_DATE%SECOND) .AND. &
       &    (YMODEL_TIME%MINUTE == PRISM_JOBEND_DATE%MINUTE) .AND. &
       &    (YMODEL_TIME%HOUR   == PRISM_JOBEND_DATE%HOUR  ) .AND. &
       &    (YMODEL_TIME%DAY    == PRISM_JOBEND_DATE%DAY   ) .AND. &
       &    (YMODEL_TIME%MONTH  == PRISM_JOBEND_DATE%MONTH ) .AND. &
       &    (YMODEL_TIME%YEAR   == PRISM_JOBEND_DATE%YEAR  )) & 
       &     LLAST=.TRUE.

! IFS does 0 to NSTOP timestep but sometimes gpmodel is not called
! at last time step but sometimes it is ?
! We do not want an exchange at the end and therefore inquire for llast  

  WRITE(NULERR,*) 'IN COUPLO4 MODE ', KMODE     

  IF (LLFIRST) THEN
   ZTIMECPL = 0.0_JPRB
   ELSE
   ZTIMECPL=ZTIMECPL+TSTEP
  ENDIF

! check if coupling time step
  IF ((ZTIMECPL /= EINCRMODEL .AND. (.NOT.LLFIRST)) .OR. LLAST ) THEN 
    WRITE(NULERR,*) 'no COUPLO4 exchange in time step ',    & 
    &    YMODEL_TIME, EINCRMODEL, TSTEP  
! reset time counter
  IF(KMODE == 1) ZTIMECPL = ZTIMECPL - TSTEP 
    IF (LHOOK) CALL DR_HOOK('COUPLO4_EXCHANGE',1,ZHOOK_HANDLE)
    RETURN
  ENDIF

! reset time counter
  IF(KMODE == 1) ZTIMECPL = ZTIMECPL - TSTEP 
  IF(KMODE == 2) ZTIMECPL = 0.0_JPRB
!  CALL GSTATS(262,0)

   WRITE(nulerr,*) ' COUPLING TIME ', YMODEL_TIME

! ---------------------------- 
!   Allocate arrays 
!-----------------------------
   
   ALLOCATE (ZLOCAL(MAX(NSPEC2,NGPTOT),NFLEVG), STAT=IERROR)
   
    WRITE(NULERR,*) 'ALLOCATED ZLOCAL ',SHAPE(ZLOCAL)    

! if exchange of global fields
  IF ( LGLOBALEXCHANGEGP ) THEN
      IF (MYPROC == MEX_PROCGP ) THEN
          ALLOCATE(ZGLOBAL(NGPTOTG,NFLEVG), STAT=IERROR)
      ENDIF
     ALLOCATE (ITO(NFLEVG), STAT=IERROR)
  ENDIF
 
  IF ( LGLOBALEXCHANGESP ) THEN
    IF ( MYPROC == MEX_PROCSP)  THEN 
       ALLOCATE (ZGLOBALSP(NSPEC2G,NFLEVG))
       ALLOCATE (ZGLOBALSP_T(NFLEVG,NSPEC2G))
    ENDIF
    IF (.NOT. ALLOCATED (ITO))  ALLOCATE( ITO(NFLEVG))
    ALLOCATE (ISETV(NFLEVG))  
  ENDIF
 

!--------------------------------------------------------------------
!                   2.   LOOP OVER PUTS AND GETS of TRANSIENT FIELDS 
!-----------------------------------------------------------------------
  INDEX_ACC = 0
  DO IFLD=1,NBR_FIELDS

   CALL MPL_BARRIER(CDSTRING='COUPLO4_EXCHANGE ')

   IF(KMODE == 2 .AND. (YFIELD_CPL(IFLD)%L_IC)) CYCLE
   IF(KMODE == 1 .AND. .NOT. (YFIELD_CPL(IFLD)%L_IC)) CYCLE
   
   IF(.NOT.(YFIELD_CPL(IFLD)%L_OUT.OR.YFIELD_CPL(IFLD)%L_IN)) CYCLE

! GRG output only at the start
   IF (.NOT.(LLFIRST) .AND.  YFIELD_CPL(IFLD)%CNAME(1:7) == 'ifs_out') CYCLE 

   IGRID_TYP= YFIELD_CPL(IFLD)%IGRID

! Local diemsnions 
    IF (IGRID_TYP == 1 .OR. IGRID_TYP == 2) THEN ! Grid point space
     I_I= NGPTOT 
     IF(IGRID_TYP == 1) I_K= NFLEVG
     IF(IGRID_TYP == 2) I_K= 1
    ENDIF

    IF (IGRID_TYP == 3 .OR. IGRID_TYP == 4) THEN ! spectral space
     I_I= NSPEC2MX ! global index space for prism is MYPROC*NSPEC2MX
     IF (LGLOBALEXCHANGESP) I_I= NSPEC2 ! only local data to get, put global
     IF(IGRID_TYP == 3) I_K= NFLEVL
     IF(IGRID_TYP == 4) I_K= 1
    ENDIF

! check allocate local data arrays
     IF(ALLOCATED(ZLOCAL).AND.     & 
      & (SIZE(ZLOCAL,1) <  I_I .OR.( SIZE(ZLOCAL,2) <  I_K))) THEN 
         DEALLOCATE( ZLOCAL) 
         WRITE(NULERR,*)' allocated ',IFLD,I_I,I_K,SIZE(ZLOCAL,1),SIZE(ZLOCAL,2)
        CALL ABOR1('ERROR something wrong with ZLOCAL')
       ENDIF  

     ZLOCAL=-999.0_JPRB 

!     IF ( IERROR /= 0 ) PRINT *, 'ERROR ALLOCATING FIELDS'
!     IF ( IERROR /= 0 ) I_ERRORS = I_ERRORS + 1
   
     LLCALLPSMILE  = .TRUE.

! test if psmile action in case of globalexchange
  IF ( LGLOBALEXCHANGEGP .AND. MYPROC /= MEX_PROCGP & 
      & .AND. ( .NOT. YFIELD_CPL(IFLD)%L_SPEC )) LLCALLPSMILE=.false.

  IF ( LGLOBALEXCHANGESP .AND. MYPROC /= MEX_PROCSP & 
      & .AND. YFIELD_CPL(IFLD)%L_SPEC )          LLCALLPSMILE=.false.

!----------------------------------------------------------------------
!                   2.1.  OUTPUT to COUPLER 
! ----------------------------------------------------------------------

   IF (YFIELD_CPL(IFLD)%L_OUT ) THEN

    IF ((.NOT.YFIELD_CPL(IFLD)%L_SPEC)) THEN ! GP fields 

      SELECT CASE (YFIELD_CPL(IFLD)%CMEM)

! 2.1.1. GMV  - extract field from GMV
! ----------------------------------------------------------------------
         CASE ('GMV') 
           DO JLEV=1,NFLEVG ! RE-ARRANGE LOOP - PERHAPS NOT EFFICIENT 
              DO JSTGLO=1,NGPTOT,NPROMA
                 ICEND=MIN(NPROMA,NGPTOT-JSTGLO+1)
                 ISTC=1
                 IBL=(JSTGLO-1)/NPROMA+1
                 !!            DO JLEV=1,NFLEVG
                 DO J=ISTC,ICEND
                    INDEX=(IBL-1)*NPROMA+J
                    ZLOCAL(INDEX, JLEV) = & 
                         &   GMV(J,JLEV,YFIELD_CPL(IFLD)%IPOINTER,IBL)
                 ENDDO
              ENDDO
           ENDDO

        

! 2.1.2 GMV  - extract single level field field from GMVS
! ----------------------------------------------------------------------

         CASE ('GMS')  
           JLEV = 1 
           DO JSTGLO=1,NGPTOT,NPROMA
              ICEND=MIN(NPROMA,NGPTOT-JSTGLO+1)
              ISTC=1
              IBL=(JSTGLO-1)/NPROMA+1
              !!            DO JLEV=1,NFLEVG
              DO J=ISTC,ICEND
                 INDEX=(IBL-1)*NPROMA+J
                 ZLOCAL(INDEX, JLEV) = & 
                      &   GMVS(J,YFIELD_CPL(IFLD)%IPOINTER,IBL)
              ENDDO
           ENDDO

          IF ( TRIM(YFIELD_CPL(IFLD)%CNAME) == 'ifs_sp' ) ZLOCAL=EXP(ZLOCAL)


! 2.1.3 GFL  - extract field from GFL 
! ----------------------------------------------------------------------
        CASE('GFL')
           DO JLEV=1,NFLEVG ! RE-ARRANGE LOOP - PERHAPS NOT EFFICIENT 
              DO JSTGLO=1,NGPTOT,NPROMA
                 ICEND=MIN(NPROMA,NGPTOT-JSTGLO+1)
                 ISTC=1
                 IBL=(JSTGLO-1)/NPROMA+1
                 !!            DO JLEV=1,NFLEVG
                 DO J=ISTC,ICEND
                    INDEX=(IBL-1)*NPROMA+J
                    ZLOCAL(INDEX, JLEV) = & 
                         &   GFL(J,JLEV,YFIELD_CPL(IFLD)%IPOINTER,IBL)
                 ENDDO
              ENDDO
           ENDDO



 ! 2.1.4 SV_VD diagnostic surface fields
 ! ----------------------------------------------------------------------

          CASE('SVD')  
           ISTAF = YFIELD_CPL(IFLD)%IPOINTER ! Pointer
           JLEV=1
          DO JSTGLO=1,NGPTOT,NPROMA
                 ICEND=MIN(NPROMA,NGPTOT-JSTGLO+1)
                 ISTC=1
                 IBL=(JSTGLO-1)/NPROMA+1
                 DO J=ISTC,ICEND
                    INDEX=(IBL-1)*NPROMA+J
                    ZLOCAL(INDEX, JLEV) = & 
                         &   SD_VD(J,YFIELD_CPL(IFLD)%IPOINTER,IBL)
                 ENDDO
           ENDDO

          IF (LLFIRST  ) THEN  
            WHERE(ZLOCAL == -999.0_JPRB) ZLOCAL=0.1_JPRB
           ENDIF          

          IF (LLFIRST .AND. CTM == "TM5" ) THEN
             WHERE(ZLOCAL == 0.0_JPRB) ZLOCAL=0.1_JPRB
          ENDIF


 ! 2.1.5 SV_VF surface fielda
 ! ----------------------------------------------------------------------

          CASE('SVF')  
           ISTAF = YFIELD_CPL(IFLD)%IPOINTER ! Pointer
           JLEV=1
          DO JSTGLO=1,NGPTOT,NPROMA
                 ICEND=MIN(NPROMA,NGPTOT-JSTGLO+1)
                 ISTC=1
                 IBL=(JSTGLO-1)/NPROMA+1
                 DO J=ISTC,ICEND
                    INDEX=(IBL-1)*NPROMA+J
                    ZLOCAL(INDEX, JLEV) = & 
                         &   SD_VF(J,YFIELD_CPL(IFLD)%IPOINTER,IBL)
                 ENDDO
           ENDDO

! 2.1.5 SV_RR surface fielda
 ! ----------------------------------------------------------------------

          CASE('SRR')  
           ISTAF = YFIELD_CPL(IFLD)%IPOINTER ! Pointer
           JLEV=1
          DO JSTGLO=1,NGPTOT,NPROMA
                 ICEND=MIN(NPROMA,NGPTOT-JSTGLO+1)
                 ISTC=1
                 IBL=(JSTGLO-1)/NPROMA+1
                 DO J=ISTC,ICEND
                    INDEX=(IBL-1)*NPROMA+J
                    ZLOCAL(INDEX, JLEV) = & 
                         &   SP_RR(J,YFIELD_CPL(IFLD)%IPOINTER,IBL)
                 ENDDO
           ENDDO

! 2.1.5 SP_SG surface fielda
 ! ----------------------------------------------------------------------

          CASE('SSG')  
           ISTAF = YFIELD_CPL(IFLD)%IPOINTER ! Pointer
           JLEV=1
          DO JSTGLO=1,NGPTOT,NPROMA
                 ICEND=MIN(NPROMA,NGPTOT-JSTGLO+1)
                 ISTC=1
                 IBL=(JSTGLO-1)/NPROMA+1
                 DO J=ISTC,ICEND
                    INDEX=(IBL-1)*NPROMA+J
                    ZLOCAL(INDEX, JLEV) = & 
                         &   SP_SG(J,YFIELD_CPL(IFLD)%IPOINTER,IBL)
                 ENDDO
           ENDDO
! 2.1.5 SP_SB surface field
 ! ----------------------------------------------------------------------

          CASE('SSB')  
           ISTAF = YFIELD_CPL(IFLD)%IPOINTER ! Pointer
           JLEV=1
          DO JSTGLO=1,NGPTOT,NPROMA
                 ICEND=MIN(NPROMA,NGPTOT-JSTGLO+1)
                 ISTC=1
                 IBL=(JSTGLO-1)/NPROMA+1
                 DO J=ISTC,ICEND
                    INDEX=(IBL-1)*NPROMA+J
                    ZLOCAL(INDEX, JLEV) = & 
                         &   SP_SB(J,1,YFIELD_CPL(IFLD)%IPOINTER,IBL)
                 ENDDO
           ENDDO
! 2.1.6  - compose field for lat/lon/lev/oro
! ----------------------------------------------------------------------
         CASE('COR')
 
          IF ( YFIELD_CPL(IFLD)%CNAME == 'ifs_slon' ) THEN
              DO JLEV=1,NFLEVG ! RE-ARRANGE LOOP - PERHAPS NOT EFFICIENT 
                 ZLOCAL(1:NGPTOT,JLEV) = SIN(GELAM(1:NGPTOT))
              ENDDO
           ENDIF
             
           IF ( YFIELD_CPL(IFLD)%CNAME == 'ifs_lat' ) THEN

              ZPI=2.0_JPRB*ASIN(1.0_JPRB)
              DO JLEV=1,NFLEVG ! RE-ARRANGE LOOP - PERHAPS NOT EFFICIENT 
                 ZLOCAL(1:NGPTOT,JLEV) = GELAT(1:NGPTOT)*(360.0_JPRB/(2.0_JPRB*ZPI))
              ENDDO
           ENDIF

           IF ( YFIELD_CPL(IFLD)%CNAME == 'ifs_lev' ) THEN
              DO JLEV=1,NFLEVG ! RE-ARRANGE LOOP - PERHAPS NOT EFFICIENT 
                 ZLOCAL(1:NGPTOT,JLEV) = FLOAT(JLEV)
              ENDDO
           ENDIF

         IF ( YFIELD_CPL(IFLD)%CNAME == 'ifs_oro' ) THEN
                 ZLOCAL(1:NGPTOT,1) = OROG (1:NGPTOT)
           ENDIF

         CASE DEFAULT        
           WRITE(NULERR,*)YFIELD_CPL(IFLD)%CNAME, YFIELD_CPL(IFLD)%CMEM  
           CALL ABOR1('UNKNOWN CMEM ' )

     END SELECT 


! "De-accumulation of accumulated fields"
!-----------------------------------------
    IF ( YFIELD_CPL(IFLD)%L_ACC ) THEN
       INDEX_ACC = INDEX_ACC + 1
       IF (INDEX_ACC > SIZE (RPREVACC,2) ) CALL ABOR1(' INDEX_ACC TO BIG ') 
       ZLOCAL(1:NGPTOT,2)= ZLOCAL(1:NGPTOT,1) 
       WRITE(NULERR,*)'DE-ACCUMULATION FOR ',YFIELD_CPL(IFLD)%CNAME,INDEX_ACC   
       IF (LLFIRST) THEN 
        ZLOCAL(1:NGPTOT,1) = ( ZLOCAL(1:NGPTOT,1) - RPREVACC(1:NGPTOT,INDEX_ACC)) / TSTEP 
       ELSE
        ZLOCAL(1:NGPTOT,1) = ( ZLOCAL(1:NGPTOT,1) - RPREVACC(1:NGPTOT,INDEX_ACC)) / EINCRMODEL
       ENDIF
       RPREVACC(1:NGPTOT,INDEX_ACC) =  ZLOCAL(1:NGPTOT,2) 
    ENDIF 


! 2.1.6 Gather fields to global fields if required
 ! ----------------------------------------------------------------------

         IF (LGLOBALEXCHANGEGP) THEN

           I_IG=NGPTOTG            

           IGRID_TYP = YFIELD_CPL(IFLD)%IGRID 
           I_KG = NFLEVG 

           IF(IGRID_TYP == 2 .OR. IGRID_TYP == 4 ) THEN
             I_KG = 1     
           ENDIF         

           IFGATHG = I_KG

           ITO=MEX_PROCGP

           CALL GATH_GRID(PGP= (RESHAPE (ZLOCAL(1:NGPTOT,1:I_KG), &
        &       (/ NGPTOT, I_KG , 1/) )),PGPG=ZGLOBAL(:,1:I_KG), &   
        &       KTO=ITO(1:I_KG),KFGATHG=IFGATHG)

         ENDIF

    ENDIF ! GP fields

  
!  2.1.7  - Spectral fields 
! ----------------------------------------------------------------------

    IF (YFIELD_CPL(IFLD)%L_SPEC ) THEN

          SELECT CASE (YFIELD_CPL(IFLD)%CNAME)

           CASE('ifs_spdiv' ) 
              DO JLEV=1,NFLEVL ! levels on V set 
                 ZLOCAL(1:NSPEC2,JLEV) = SPDIV(JLEV,1:NSPEC2)
              ENDDO

             
           CASE ('ifs_spvor' ) 
              DO JLEV=1,NFLEVL ! levels on V set 
                 ZLOCAL(1:NSPEC2,JLEV) = SPVOR(JLEV,1:NSPEC2)
              ENDDO


           CASE ('ifs_spsp') 
               JLEV=1  
               ZLOCAL(1:NSPEC2,JLEV) = SPSP(1:NSPEC2)
               IF( NPSP == 0 ) ZLOCAL(1:NSPEC2MX,JLEV) = -9999999.9 
       
           CASE ('ifs_spinf3d' ) 
              DO JLEV=1,NFLEVL ! levels on V set
                ILEVSP=NPTRLL(MYSETV)+JLEV-1        
                 IC=1
                  DO JMLOC=1,NUMP        
                    IM=MYMS(JMLOC)
                      DO JN=IM,NSMAX
                        ZLOCAL(IC,  JLEV)=FLOAT(IM*1000+JN) + FLOAT(ILEVSP)*0.01_JPRB 
                        ZLOCAL(IC+1,JLEV)= -1.0 * ZLOCAL(IC,JLEV)
                        IC=IC+2
                      ENDDO
                  ENDDO
              ENDDO 


           CASE ('ifs_spinf2d' ) 
                  IC=1 
                  JLEV=1
                  DO JMLOC=1,NUMP
                    IM=MYMS(JMLOC)
                      DO JN=IM,NSMAX
                        ZLOCAL(IC,  JLEV)=FLOAT(IM*1000+JN)
                        ZLOCAL(IC+1,JLEV)= -1.0 * ZLOCAL(IC,JLEV)
                        IC=IC+2
                      ENDDO
                  ENDDO
                  IF( NPSP == 0 ) ZLOCAL(1:NSPEC2MX,JLEV) = -9999999.9 
           CASE default  


           END SELECT 


 ! 2.1.8  Gather spectral fields to global fields if required
 ! ----------------------------------------------------------------------

    IF (LGLOBALEXCHANGESP) THEN

           IGRID_TYP= YFIELD_CPL(IFLD)%IGRID 
           I_KG = NFLEVG 
           I_IG = NSPEC2G 
 
! use gath_spec for 3d fields
        IF(IGRID_TYP == 3 ) THEN 
            I_KG = NFLEVG 
            I_IG = NSPEC2G 
  
            IFGATHG = I_KG  ! Fields

            ITO=MEX_PROCSP
            ISETV=NBSETLEV

            IF( MYPROC /= MEX_PROCSP) THEN
              CALL GATH_SPEC( & 
             &     KFGATHG=IFGATHG,KTO=ITO,KVSET=ISETV, &
             &     PSPEC=TRANSPOSE(ZLOCAL(1:NSPEC2,1:NFLEVL))) 
             ELSE
              ZGLOBALSP_T=0.0_JPRB 
              CALL GATH_SPEC(PSPECG=ZGLOBALSP_T(1:I_KG,1:NSPEC2G) , & 
             &     KFGATHG=IFGATHG,KTO=ITO,KVSET=ISETV, &
             &     PSPEC=TRANSPOSE(ZLOCAL(1:NSPEC2,1:NFLEVL))) 

              IF (YFIELD_CPL(IFLD)%CNAME == 'ifs_spinf3d' ) THEN 
! correct for zeros from gath_spec at wavenumber 0
               DO I=1,NSPEC2G,2
                IF (ZGLOBALSP_T(1,I+1) /= -1.0*(ZGLOBALSP_T(1,I)))THEN
                 ZGLOBALSP_T(1:I_KG,I+1) = -1.0*ZGLOBALSP_T(1:I_KG,I) 
                ENDIF
               ENDDO
              ENDIF

             ZGLOBALSP=TRANSPOSE(ZGLOBALSP_T)
            ENDIF
  
       ENDIF

  IF(IGRID_TYP == 4 ) THEN 
!       use direct send & receive because 2d gathspec did not work 
         I_KG =  1
         I_IG = NPROC*NSPEC2MX 

         IRECVCOUNTS(1:NPROC)=1 
         ZNPSP(1)=FLOAT(NPSP)     

! Gather NPSP,  ZALLNPSP is NPSPS for each processes           
      CALL MPL_GATHERV(ZNPSP,KROOT=MEX_PROCSP,&
        & PRECVBUF=ZALLNPSP,KRECVCOUNTS=IRECVCOUNTS, &
        & CDSTRING='COUPLO4_EXCHANGE NPSP INFO ')
      IF (NPSP == 1) THEN
           CALL MPL_SEND(ZLOCAL(1:NSPEC2,1:1),KDEST=MEX_PROCSP,KTAG=122469, &
          & CDSTRING='COUPLO4_EXCHANGE ')
       ENDIF  

       IF( MYPROC == MEX_PROCSP) THEN
          IOFFSET=0 
            ZGLOBAL=-999.0_JPRB 
             DO IPROC=1,NPROC
              IF (ZALLNPSP(IPROC) /= 1.0 ) CYCLE
              CALL MPL_RECV( & 
                & ZLOCAL(1:NSPEC2MX,1:1) , & 
                & KSOURCE=IPROC,KTAG=122469, KMP_TYPE=JP_BLOCKING_STANDARD, &
                & CDSTRING='COUPLO4_EXCHANGE ')
               ZGLOBALSP(1+IOFFSET:IOFFSET+NSPEC2MX,1:1) = ZLOCAL(1:NSPEC2MX,1:1)
               WRITE(NULERR,*) 'valid 2dsp received from PROC ', IPROC, IOFFSET
               IOFFSET=IOFFSET+NSPEC2MX
             ENDDO
             I_IG=IOFFSET                
       ENDIF
    ENDIF

 
  ENDIF 
 ENDIF

 ! 2.1.5 Put Field to coupler
 ! ----------------------------------------------------------------------

        IF(KIND(ZLOCAL) /= 8 ) THEN
           CALL ABOR1('ERROR Field must be Double_Precision')
        ENDIF


        IF (LLCALLPSMILE) THEN 

!          IF(IGRID_TYP == 1) IGSTATS=264 
!          IF(IGRID_TYP == 2) IGSTATS=265     
!          IF(IGRID_TYP == 3) IGSTATS=266 
!          IF(IGRID_TYP == 4) IGSTATS=267 

!       CALL GSTATS(IGSTATS,0)

   IF (LGLOBALEXCHANGEGP .OR.  LGLOBALEXCHANGESP) THEN

     IF (YFIELD_CPL(IFLD)%L_SPEC  ) then
        ZGLOBAL(1:I_IG,1:I_KG)=ZGLOBALSP(1:I_IG,1:I_KG) 
     ENDIF    

     CALL PRISM_PUT ( YFIELD_CPL(IFLD)%ID, YMODEL_TIME, & 
      & YMODEL_TIME_BOUNDS, ZGLOBAL(1:I_IG,1:I_KG), INFO, IERROR )
     WRITE(NULERR,*) 'AFTER PUT GB MAX MIN ',TRIM(YFIELD_CPL(IFLD)%CNAME), &
      & MAXVAL(ZGLOBAL(1:I_IG,1:I_KG)),MINVAL(ZGLOBAL(1:I_IG,1:I_KG)),I_IG,I_KG

   ELSE        
      CALL PRISM_PUT ( YFIELD_CPL(IFLD)%ID, YMODEL_TIME, & 
      & YMODEL_TIME_BOUNDS, ZLOCAL(1:I_I,1:I_K), INFO, IERROR )
  
 !        CALL GSTATS(IGSTATS,1)

      WRITE(NULERR,*) 'AFTER PUT MAX MIN ',TRIM(YFIELD_CPL(IFLD)%CNAME), &
      & MAXVAL(ZLOCAL(1:I_I,1:I_K)),MINVAL(ZLOCAL(1:I_I,1:I_K)),I_I,I_K

   ENDIF
  
  ENDIF  

ENDIF

 !----------------------------------------------------------------------
 !                   2.2.  INPUT from COUPLER 
 ! ----------------------------------------------------------------------


 ! 2.2.1 Get field from coupler ! Only 3d GP fields
 ! ----------------------------------------------------------------------

     IF (YFIELD_CPL(IFLD)%L_IN ) THEN

      IF (IERROR /= 0) I_ERRORS = I_ERRORS + 1

          INFO=-999
      IF (LLCALLPSMILE) THEN 

           I_KG = NFLEVG 
           I_K = NFLEVG 
           I_IG = NGPTOTG 
           I_I = NGPTOT 
           IF(IGRID_TYP == 2 )I_KG = 1 
 
       IF (LGLOBALEXCHANGEGP ) THEN
       
        CALL PRISM_GET ( YFIELD_CPL(IFLD)%ID, YMODEL_TIME, &
             & YMODEL_TIME_BOUNDS, ZGLOBAL(1:I_IG,1:I_KG), INFO, IERROR )
        WRITE(NULERR,*) 'AFTER GET GLOBAL MAX MIN ',TRIM(YFIELD_CPL(IFLD)%CNAME), & 
              &    MAXVAL(ZGLOBAL(1:I_IG,1:I_KG)),MINVAL(ZGLOBAL(1:I_IG,1:I_KG))
       ELSE
 
          CALL PRISM_GET ( YFIELD_CPL(IFLD)%ID, YMODEL_TIME, &
             & YMODEL_TIME_BOUNDS, ZLOCAL(1:I_I,1:I_K), INFO, IERROR )

          WRITE(NULERR,*) 'AFTER GET MAX MIN ',TRIM(YFIELD_CPL(IFLD)%CNAME), & 
              &    MAXVAL(ZLOCAL(1:I_I,1:I_K)),MINVAL(ZLOCAL(1:I_I,1:I_K)),MINLOC(ZLOCAL(1:I_I,1:I_K))

       ENDIF
  
!          CALL GSTATS(263,1)

     ENDIF ! lcallpsmile

         IF (INFO /= 1000) THEN !1000 is new info code since oasisver=20060420
          WRITE(NULERR,*) 'NO DATA EXCHANGED ', INFO, IERROR 
!          CYCLE

         ENDIF
      
! 2.2.2 Redistribute and or Re-shape to nproma blocked array  
! ----------------------------------------------------------------------

   IF(.NOT. ALLOCATED(ZLOCGP)) ALLOCATE(ZLOCGP(NPROMA,NFLEVG,NGPBLKS), STAT=IERROR )
   ZLOCGP=-99999.9_JPRB
! redistribute and re-shape in one go 
  IF (LGLOBALEXCHANGEGP) THEN

       ITO=MEX_PROCGP 

   CALL MPL_BARRIER(CDSTRING='COUPLO4_EXCHANGE 1')
       CALL DIST_GRID (PGPG=ZGLOBAL, PGP=ZLOCGP, KFROM=ITO, & 
         &  KPROMA=NPROMA, KFDISTG=NFLEVG)

   CALL MPL_BARRIER(CDSTRING='COUPLO4_EXCHANGE 2')
  ELSE

! only re-shape from (1:NGPTOT,NLEV) to     (1:NPOMA,NLEV,IBLK)  

  ZLOCGP=-9999999999.0_JPRB

    DO JLEV=1,NFLEVG ! RE-ARRANGE LOOP  
          DO JSTGLO=1,NGPTOT,NPROMA
              ICEND=MIN(NPROMA,NGPTOT-JSTGLO+1)
                ISTC=1
                IBL=(JSTGLO-1)/NPROMA+1
                 DO J=ISTC,ICEND
                    INDEX=(IBL-1)*NPROMA+J
                    ZLOCGP(J,JLEV,IBL)= ZLOCAL(INDEX, JLEV)
                 ENDDO
             ENDDO
        ENDDO

 ENDIF ! 



! 2.2.3 Put fields from CTM in GRG auxillary arrays   
! -----------------------------------------------------

     IF (YFIELD_CPL(IFLD)%CMEM == 'GRG' ) THEN
          CALL COUPLO4_GRG_INPUT & 
        &   (YFIELD_CPL(IFLD)%CNAME, ZLOCGP, LLFIRST)
     ENDIF
    

  ENDIF   !    (YFIELD_CPL(IFLD)%L_IN)

 IF (LLFIRST .AND. CTM == 'TM5') THEN
   IF (YFIELD_CPL(IFLD)%CNAME(1:7)== 'ifs_oro')YFIELD_CPL(IFLD)%L_OUT=.FALSE.
   IF (YFIELD_CPL(IFLD)%CNAME(1:7)== 'ifs_lsm')YFIELD_CPL(IFLD)%L_OUT=.FALSE.
   IF (YFIELD_CPL(IFLD)%CNAME(1:7)== 'ifs_spi')YFIELD_CPL(IFLD)%L_OUT=.FALSE.
 ENDIF
ENDDO ! loop over transient variables 



! De-allocation == should be in last step only
  IF (ALLOCATED (ZLOCGP))  DEALLOCATE (ZLOCGP)
  IF (ALLOCATED (ZLOCAL))  DEALLOCATE (ZLOCAL)
  IF (ALLOCATED (ZGLOBAL)) DEALLOCATE (ZGLOBAL) 
  IF (ALLOCATED (ZGLOBALSP)) DEALLOCATE (ZGLOBALSP)
  IF (ALLOCATED (ITO))     DEALLOCATE (ITO)
  IF (ALLOCATED (ISETV))   DEALLOCATE (ISETV)
!  IF (ALLOCATED (ZGPP))    DEALLOCATE (ZGPP)

!----------------------------------------------------------------------
!                   3.   TOTAL INTEGRALS  
! ----------------------------------------------------------------------

! IF (LDIA_GRG .AND. KMODE == 1) CALL COUPLO4_GRG_STATS(LLFIRST)

!----------------------------------------------------------------------
!                   4.   TIME UPDATE 
! ----------------------------------------------------------------------
IF (KMODE == 2) THEN 
 CALL PRISM_CALC_NEWDATE ( YMODEL_TIME_BOUNDS(1), EINCRMODEL, IERROR )
 CALL PRISM_CALC_NEWDATE ( YMODEL_TIME_BOUNDS(2), EINCRMODEL, IERROR )
 CALL PRISM_CALC_NEWDATE ( YMODEL_TIME, EINCRMODEL, IERROR )
 
 WRITE(NULERR,*) 'UPDATE AFTER EXCHANGE ', YMODEL_TIME, EINCRMODEL, IERROR
ENDIF

CALL MPL_BARRIER(CDSTRING='COUPLO4_EXCHANGE END')

! CALL GSTATS(262,1)

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

END SUBROUTINE COUPLO4_EXCHANGE

