!
! $Header$
!
MODULE oasis
!
! This module contains subroutines for initialization, sending and receiving 
! towards the coupler OASIS3. It also contains some parameters for the coupling.
!
! This module should always be compiled. With the coupler OASIS3 available the cpp key
! CPP_COUPLE should be set and the entier of this file will then be compiled. 
! In a forced mode CPP_COUPLE should not be defined and the compilation ends before 
! the CONTAINS, without compiling the subroutines.
!
  USE dimphy 
  USE mod_phys_lmdz_para
  USE write_field_phy

#ifdef CPP_COUPLE
  USE mod_prism_proto
  USE mod_prism_def_partition_proto
  USE mod_prism_get_proto
  USE mod_prism_put_proto
#endif
  
  IMPLICIT NONE
    
! Maximum number of fields exchanged between ocean and atmosphere
  INTEGER, PARAMETER  :: jpmaxfld=40
! Number of fields exchanged from atmosphere to ocean via flx.F
  INTEGER, PARAMETER  :: jpflda2o1=13
! Number of fields exchanged from atmosphere to ocean via tau.F
  INTEGER, PARAMETER  :: jpflda2o2=6
! Number of fields exchanged from ocean to atmosphere
  INTEGER, PARAMETER  :: jpfldo2a=4

  CHARACTER (len=8), DIMENSION(jpmaxfld), PUBLIC, SAVE   :: cl_read
  !$OMP THREADPRIVATE(cl_read)
  CHARACTER (len=8), DIMENSION(jpmaxfld), PUBLIC, SAVE   :: cl_writ
  !$OMP THREADPRIVATE(cl_writ)

  INTEGER, DIMENSION(jpfldo2a), SAVE, PRIVATE            :: in_var_id
  !$OMP THREADPRIVATE(in_var_id)
  INTEGER, DIMENSION(jpflda2o1+jpflda2o2), SAVE, PRIVATE :: out_var_id
  !$OMP THREADPRIVATE(out_var_id)


#ifdef CPP_COUPLE

CONTAINS

  SUBROUTINE inicma
!************************************************************************************
!**** *INICMA*  - Initialize coupled mode communication for atmosphere
!                 and exchange some initial information with Oasis
!
!     Rewrite to take the PRISM/psmile library into account
!     LF 09/2003
!
    INCLUDE "dimensions.h"

! Local variables
!************************************************************************************
    INTEGER                            :: comp_id
    INTEGER                            :: ierror, il_commlocal
    INTEGER                            :: il_part_id
    INTEGER, DIMENSION(3)              :: ig_paral
    INTEGER, DIMENSION(2)              :: il_var_nodims
    INTEGER, DIMENSION(4)              :: il_var_actual_shape
    INTEGER                            :: il_var_type
    INTEGER                            :: nuout = 6
    INTEGER                            :: jf
    CHARACTER (len = 6)                :: clmodnam
    CHARACTER (len = 20)               :: modname = 'inicma'
    CHARACTER (len = 80)               :: abort_message 

!*    1. Initializations
!        ---------------
!************************************************************************************
    WRITE(nuout,*) ' '
    WRITE(nuout,*) ' '
    WRITE(nuout,*) ' ROUTINE INICMA'
    WRITE(nuout,*) ' **************'
    WRITE(nuout,*) ' '
    WRITE(nuout,*) ' '

!
! Define the model name
!
    clmodnam = 'lmdz.x'       ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
!
!************************************************************************************
! Here we go: psmile initialisation
!************************************************************************************
    IF (is_sequential) THEN
       CALL prism_init_comp_proto (comp_id, clmodnam, ierror)
       
       IF (ierror .NE. PRISM_Ok) THEN
          abort_message=' Probleme init dans prism_init_comp '
          CALL abort_gcm(modname,abort_message,1)
       ELSE
          WRITE(nuout,*) 'inicma : init psmile ok '
       ENDIF
    ENDIF

    CALL prism_get_localcomm_proto (il_commlocal, ierror)
!************************************************************************************
! Domain decomposition
!************************************************************************************
    ig_paral(1) = 1                            ! apple partition for //
    ig_paral(2) = (jj_begin-1)*iim+ii_begin-1  ! offset
    ig_paral(3) = (jj_end*iim+ii_end) - (jj_begin*iim+ii_begin) + 1

    IF (mpi_rank==mpi_size-1) ig_paral(3)=ig_paral(3)+iim-1
    WRITE(nuout,*) mpi_rank,'ig_paral--->',ig_paral(2),ig_paral(3)
    
    ierror=PRISM_Ok
    CALL prism_def_partition_proto (il_part_id, ig_paral, ierror)

    IF (ierror .NE. PRISM_Ok) THEN
       abort_message=' Probleme dans prism_def_partition '
       CALL abort_gcm(modname,abort_message,1)
    ELSE
       WRITE(nuout,*) 'inicma : decomposition domaine psmile ok '
    ENDIF

!************************************************************************************
! Field Declarations
!************************************************************************************
!     Define symbolic name for fields exchanged from atmos to coupler,
!         must be the same as (1) of the field  definition in namcouple:
    cl_writ(1)='COTAUXXU'
    cl_writ(2)='COTAUYYU'
    cl_writ(3)='COTAUZZU'
    cl_writ(4)='COTAUXXV'
    cl_writ(5)='COTAUYYV'
    cl_writ(6)='COTAUZZV'
    cl_writ(7)='COWINDSP'
    cl_writ(8)='COSHFICE'
    cl_writ(9)='COSHFOCE'
    cl_writ(10)='CONSFICE'
    cl_writ(11)='CONSFOCE'
    cl_writ(12)='CODFLXDT'
    cl_writ(13)='COTFSICE'
    cl_writ(14)='COTFSOCE'
    cl_writ(15)='COTOLPSU'
    cl_writ(16)='COTOSPSU'
    cl_writ(17)='CORUNCOA'
    cl_writ(18)='CORIVFLU'
    cl_writ(19)='COCALVIN'
!
!     Define symbolic name for fields exchanged from coupler to atmosphere,
!         must be the same as (2) of the field  definition in namcouple:
!
    cl_read(1)='SISUTESW'
    cl_read(2)='SIICECOV'
    cl_read(3)='SIICEALW'
    cl_read(4)='SIICTEMW'
    
    il_var_nodims(1) = 2
    il_var_nodims(2) = 1

    il_var_actual_shape(1) = 1
    il_var_actual_shape(2) = iim
    il_var_actual_shape(3) = 1
    il_var_actual_shape(4) = jjm+1
   
    il_var_type = PRISM_Real

!************************************************************************************
! Oceanic Fields
!************************************************************************************
    DO jf=1, jpfldo2a
       CALL prism_def_var_proto(in_var_id(jf), cl_read(jf), il_part_id, &
            il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, &
            ierror)
       IF (ierror .NE. PRISM_Ok) THEN
          abort_message=' Probleme init dans prism_def_var_proto '
          CALL abort_gcm(modname,abort_message,1)
       ENDIF
    END DO

!************************************************************************************
! Atmospheric Fields
!************************************************************************************
    DO jf=1, jpflda2o1+jpflda2o2
       CALL prism_def_var_proto(out_var_id(jf), cl_writ(jf), il_part_id, &
            il_var_nodims, PRISM_Out, il_var_actual_shape, il_var_type, &
            ierror)
       IF (ierror .NE. PRISM_Ok) THEN
          abort_message=' Probleme init dans prism_def_var_proto '
          CALL abort_gcm(modname,abort_message,1)
       ENDIF
    END DO

!************************************************************************************
! End definition
!************************************************************************************
    CALL prism_enddef_proto(ierror)
    IF (ierror .NE. PRISM_Ok) THEN
       abort_message=' Probleme init dans prism_ endef_proto'
       CALL abort_gcm(modname,abort_message,1)
    ELSE
       WRITE(nuout,*) 'inicma : endef psmile ok '
    ENDIF
    
  END SUBROUTINE inicma

!
!************************************************************************************
!

  SUBROUTINE fromcpl(ktime, tab_get)
! ======================================================================
! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine reads the SST 
! and Sea-Ice provided by the coupler. Adaptation to psmile library
!======================================================================
!
    INCLUDE "dimensions.h"
! Input arguments
!************************************************************************************
    INTEGER, INTENT(IN)                               ::  ktime

! Output arguments
!************************************************************************************
    REAL, DIMENSION(iim, jj_nb,jpfldo2a), INTENT(OUT) :: tab_get

! Local variables
!************************************************************************************
    INTEGER                       :: nuout  = 6             ! listing output unit
    INTEGER                       :: ierror, i
    INTEGER                       :: istart,iend
    CHARACTER (len = 20)          :: modname = 'fromcpl'
    CHARACTER (len = 80)          :: abort_message 
    REAL, DIMENSION(iim*jj_nb)    :: field

!************************************************************************************
    WRITE (nuout,*) ' '
    WRITE (nuout,*) 'Fromcpl: Reading fields from CPL, ktime=',ktime
    WRITE (nuout,*) ' '
    CALL flush (nuout)
    
    istart=ii_begin
    IF (is_south_pole) THEN
       iend=(jj_end-jj_begin)*iim+iim
    ELSE
       iend=(jj_end-jj_begin)*iim+ii_end
    ENDIF
    
    DO i = 1, jpfldo2a
       field(:) = -99999.
       CALL prism_get_proto(in_var_id(i), ktime, field(istart:iend), ierror)
       tab_get(:,:,i) = RESHAPE(field(:),(/iim,jj_nb/))
       
       IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Recvd .AND. &
            ierror.NE.PRISM_FromRest &
            .AND. ierror.NE.PRISM_Input .AND. ierror.NE.PRISM_RecvOut &
            .AND. ierror.NE.PRISM_FromRestOut) THEN
          WRITE (nuout,*)  cl_read(i), ktime   
          abort_message=' Probleme dans prism_get_proto '
          CALL abort_gcm(modname,abort_message,1)
       ENDIF
    END DO
    
    
  END SUBROUTINE fromcpl

!
!************************************************************************************
! 

  SUBROUTINE intocpl(ktime, last, tab_put) 
! ======================================================================
! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the 
! atmospheric coupling fields to the coupler with the psmile library.
! IF last time step, writes output fields to binary files.
! ======================================================================
!
! 
    INCLUDE "dimensions.h"
! Input arguments
!************************************************************************************
    INTEGER, INTENT(IN)                                          :: ktime
    LOGICAL, INTENT(IN)                                          :: last
    REAL, DIMENSION(iim, jj_nb, jpflda2o1+jpflda2o2), INTENT(IN) :: tab_put

! Local variables
!************************************************************************************
    LOGICAL                     :: checkout=.FALSE.
    INTEGER                     :: istart,iend
    INTEGER                     :: wstart,wend
    INTEGER, PARAMETER          :: nuout = 6 
    INTEGER                     :: ierror, i
    REAL, DIMENSION(iim*jj_nb)  :: field
    CHARACTER (len = 20),SAVE   :: modname = 'intocpl'
    CHARACTER (len = 80)        :: abort_message 

!************************************************************************************

    WRITE(nuout,*) ' '
    WRITE(nuout,*) 'Intocpl: sending fields to CPL, ktime= ', ktime
    WRITE(nuout,*) 'last  ', last
    WRITE(nuout,*)


    istart=ii_begin
    IF (is_south_pole) THEN
       iend=(jj_end-jj_begin)*iim+iim
    ELSE
       iend=(jj_end-jj_begin)*iim+ii_end
    ENDIF
    
    IF (checkout) THEN   
       wstart=istart
       wend=iend
       IF (is_north_pole) wstart=istart+iim-1
       IF (is_south_pole) wend=iend-iim+1
       
       field = RESHAPE(tab_put(:,:,8),(/iim*jj_nb/))
       CALL writeField_phy("fsolice",field(wstart:wend),1)
       field = RESHAPE(tab_put(:,:,9),(/iim*jj_nb/))
       CALL writeField_phy("fsolwat",field(wstart:wend),1)
       field = RESHAPE(tab_put(:,:,10),(/iim*jj_nb/))
       CALL writeField_phy("fnsolice",field(wstart:wend),1)
       field = RESHAPE(tab_put(:,:,11),(/iim*jj_nb/))
       CALL writeField_phy("fnsolwat",field(wstart:wend),1)
       field = RESHAPE(tab_put(:,:,12),(/iim*jj_nb/))
       CALL writeField_phy("fnsicedt",field(wstart:wend),1)
       field = RESHAPE(tab_put(:,:,13),(/iim*jj_nb/))
       CALL writeField_phy("evice",field(wstart:wend),1)
       field = RESHAPE(tab_put(:,:,14),(/iim*jj_nb/))
       CALL writeField_phy("evwat",field(wstart:wend),1)
       field = RESHAPE(tab_put(:,:,15),(/iim*jj_nb/))
       CALL writeField_phy("lpre",field(wstart:wend),1)
       field = RESHAPE(tab_put(:,:,16),(/iim*jj_nb/))
       CALL writeField_phy("spre",field(wstart:wend),1)
       field = RESHAPE(tab_put(:,:,17),(/iim*jj_nb/))
       CALL writeField_phy("dirunoff",field(wstart:wend),1)
       field = RESHAPE(tab_put(:,:,18),(/iim*jj_nb/))
       CALL writeField_phy("rivrunoff",field(wstart:wend),1)
       field = RESHAPE(tab_put(:,:,19),(/iim*jj_nb/))
       CALL writeField_phy("calving",field(wstart:wend),1)
       field = RESHAPE(tab_put(:,:,1),(/iim*jj_nb/))
       CALL writeField_phy("tauxx_u",field(wstart:wend),1)
       field = RESHAPE(tab_put(:,:,2),(/iim*jj_nb/))
       CALL writeField_phy("tauyy_u",field(wstart:wend),1)
       field = RESHAPE(tab_put(:,:,3),(/iim*jj_nb/))
       CALL writeField_phy("tauzz_u",field(wstart:wend),1)
       field = RESHAPE(tab_put(:,:,4),(/iim*jj_nb/))
       CALL writeField_phy("tauxx_v",field(wstart:wend),1)
       field = RESHAPE(tab_put(:,:,5),(/iim*jj_nb/))
       CALL writeField_phy("tauyy_v",field(wstart:wend),1)
       field = RESHAPE(tab_put(:,:,6),(/iim*jj_nb/))
       CALL writeField_phy("tauzz_v",field(wstart:wend),1)
       field = RESHAPE(tab_put(:,:,7),(/iim*jj_nb/))
       CALL writeField_phy("windsp",field(wstart:wend),1)
    ENDIF
   
!************************************************************************************
! PRISM_PUT
!************************************************************************************

    DO i = 1, jpflda2o1+jpflda2o2
       field = RESHAPE(tab_put(:,:,i),(/iim*jj_nb/))
       CALL prism_put_proto(out_var_id(i), ktime, field(istart:iend), ierror)
       
       IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Sent .AND. ierror.NE.PRISM_ToRest &
            .AND. ierror.NE.PRISM_LocTrans .AND. ierror.NE.PRISM_Output .AND. &
            ierror.NE.PRISM_SentOut .AND. ierror.NE.PRISM_ToRestOut) THEN
          WRITE (nuout,*)  cl_writ(i), ktime   
          abort_message=' Probleme dans prism_put_proto '
          CALL abort_gcm(modname,abort_message,1)
       ENDIF
       
    END DO
   
!************************************************************************************
! Finalize PSMILE for the case is_sequential, if parallel finalization is done 
! from Finalize_parallel in dyn3dpar/parallel.F90
!************************************************************************************

    IF (last) THEN
       IF (is_sequential) THEN 
          CALL prism_terminate_proto(ierror)
          IF (ierror .NE. PRISM_Ok) THEN
             abort_message=' Probleme dans prism_terminate_proto '
             CALL abort_gcm(modname,abort_message,1)
          ENDIF
       ENDIF
    ENDIF
    
    
  END SUBROUTINE intocpl

#endif
  
END MODULE oasis
