!
! $Header$
!

  MODULE oasis

! Module contenant les routines pour l'initialisation du couplage, la
! lecture et l'ecriture des champs venant/transmis au coupleur
!

  IMPLICIT none

  PRIVATE
  PUBLIC :: inicma, fromcpl, intocpl

  INTERFACE inicma
    module procedure inicma
  END INTERFACE  

#include "param_cou.h"

   integer, dimension(jpfldo2a), save              :: in_var_id
   integer, dimension(jpflda2o1+jpflda2o2), save  :: il_out_var_id
   CHARACTER (len=8), dimension(jpmaxfld), save   :: cl_writ, cl_read
   CHARACTER (len=8), dimension(jpmaxfld), save   :: cl_f_writ, cl_f_read

CONTAINS

!****
!
!**** *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
!
!     Input:
!     -----
!        im, jm: size of grid passed between gcm and coupler
!
!     -----------------------------------------------------------
!
   SUBROUTINE inicma(im, jm)

   use mod_prism_proto
   use mod_prism_def_partition_proto

   implicit none

#include "param_cou.h"

!
! parameters
!
   integer                  :: im, jm
!
! local variables
!
! integers
!
   integer                                  :: comp_id
   integer                                  :: ierror
   integer                                  :: il_part_id
   integer, dimension(:), allocatable       :: ig_paral
   integer, dimension(jpfldo2a)             :: in_var_id
   integer, dimension(jpflda2o1+jpflda2o2)  :: il_out_var_id
   integer, dimension(2)                    :: il_var_nodims
   integer, dimension(4)                    :: il_var_actual_shape
   integer                                  :: il_var_type
   integer                                  :: nuout = 6
   integer                                  :: jf
! characters
!
   character (len = 6)        :: clmodnam
   character (len = 20),save  :: 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
!
   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

!
! and domain decomposition
!
! monoproc case
!
   allocate(ig_paral(3))
   ig_paral(1) = 0
   ig_paral(2) = 0
   ig_paral(3) = im * jm

   call prism_def_partition_proto (il_part_id, ig_paral, ierror)
   deallocate(ig_paral)
!
   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)='COSHFICE'
   cl_writ(2)='COSHFOCE'
   cl_writ(3)='CONSFICE'
   cl_writ(4)='CONSFOCE'
   cl_writ(5)='CODFLXDT'
   cl_writ(6)='COTFSICE'
   cl_writ(7)='COTFSOCE'
   cl_writ(8)='COTOLPSU'
   cl_writ(9)='COTOSPSU'
   cl_writ(10)='CORUNCOA'
   cl_writ(11)='CORIVFLU'
   cl_writ(12)='COCALVIN'
   cl_writ(13)='COTAUXXU'
   cl_writ(14)='COTAUYYU'
   cl_writ(15)='COTAUZZU'
   cl_writ(16)='COTAUXXV'
   cl_writ(17)='COTAUYYV'
   cl_writ(18)='COTAUZZV'
!
!     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) = im
   il_var_actual_shape(3) = 1
   il_var_actual_shape(4) = jm
   
   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(il_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
!
   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(kt, im, jm, sst, gla, tice, albedo)
! ======================================================================
! 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
!======================================================================

   use mod_prism_proto
   use mod_prism_get_proto

   IMPLICIT none

!
! parametres
!
   integer                 :: im, jm, kt
   real, dimension(im, jm)   :: sst            ! sea-surface-temperature
   real, dimension(im, jm)   :: gla     ! sea-ice
   real, dimension(im, jm)   :: tice    ! temp glace
   real, dimension(im, jm)   :: albedo  ! albedo glace
!
! local variables
!
   integer                 :: nuout  = 6             ! listing output unit
   integer                 :: ierror
   character (len = 20),save  :: modname = 'fromcpl'
   character (len = 80)       :: abort_message 
!
#include "param_cou.h"
!
!
   WRITE (nuout,*) ' '
   WRITE (nuout,*) 'Fromcpl: Reading fields from CPL, kt=',kt
   WRITE (nuout,*) ' '
   CALL flush (nuout)

   call prism_get_proto(in_var_id(1), kt, sst, ierror)
   IF (ierror .ne. PRISM_Ok) THEN
     WRITE (nuout,*)  cl_read(1), kt   
     abort_message=' Probleme dans prism_get_proto '
     call abort_gcm(modname,abort_message,1)
   endif
   call prism_get_proto(in_var_id(2), kt, gla, ierror)
   IF (ierror .ne. PRISM_Ok) THEN
     WRITE (nuout,*)  cl_read(2), kt   
     abort_message=' Probleme dans prism_get_proto '
     call abort_gcm(modname,abort_message,1)
   endif
   call prism_get_proto(in_var_id(3), kt, albedo, ierror)
   IF (ierror .ne. PRISM_Ok) THEN
     WRITE (nuout,*)  cl_read(3), kt   
     abort_message=' Probleme dans prism_get_proto '
     call abort_gcm(modname,abort_message,1)
   endif
   call prism_get_proto(in_var_id(4), kt, tice, ierror)
   IF (ierror .ne. PRISM_Ok) THEN
     WRITE (nuout,*)  cl_read(4), kt   
     abort_message=' Probleme dans prism_get_proto '
     call abort_gcm(modname,abort_message,1)
   endif

!
   RETURN
   END SUBROUTINE fromcpl

   SUBROUTINE intocpl(kt, im, jm, fsolice, fsolwat, fnsolice, fnsolwat, &
 &    fnsicedt, evice, evwat, lpre, spre, dirunoff, rivrunoff, & 
 &    calving, tauxx_u, tauyy_u, tauzz_u, tauxx_v, tauyy_v, tauzz_v &
 &    , last) 
! ======================================================================
! 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.
! ======================================================================

   use mod_prism_proto
   use mod_prism_put_proto

   IMPLICIT NONE

! 
! parametres
!
   integer               :: kt, im, jm
   real, dimension(im, jm) :: fsolice, fsolwat, fnsolwat, fnsolice
   real, dimension(im, jm) :: fnsicedt, evice, evwat, lpre, spre
   real, dimension(im, jm) :: dirunoff, rivrunoff, calving
   real, dimension(im, jm) :: tauxx_u, tauxx_v, tauyy_u
   real, dimension(im, jm) :: tauyy_v, tauzz_u, tauzz_v
   logical               :: last
!
! local
!
   integer, parameter    :: nuout = 6 
   integer               :: ierror
   character (len = 20),save  :: modname = 'intocpl'
   character (len = 80)       :: abort_message 
!
!
      WRITE(nuout,*) ' '
      WRITE(nuout,*) 'Intocpl: sending fields to CPL, kt= ', kt
      WRITE(nuout,*) 'last  ', last
      WRITE(nuout,*)

   call prism_put_proto(il_out_var_id(1), kt, fsolice, ierror)
   IF (ierror .ne. PRISM_Ok) THEN
     WRITE (nuout,*)  cl_writ(1), kt   
     abort_message=' Probleme dans prism_put_proto '
     call abort_gcm(modname,abort_message,1)
   endif
   call prism_put_proto(il_out_var_id(2), kt, fsolwat, ierror)
   IF (ierror .ne. PRISM_Ok) THEN
     WRITE (nuout,*)  cl_writ(2), kt   
     abort_message=' Probleme dans prism_put_proto '
     call abort_gcm(modname,abort_message,1)
   endif
   call prism_put_proto(il_out_var_id(3), kt, fnsolice, ierror)
   IF (ierror .ne. PRISM_Ok) THEN
     WRITE (nuout,*)  cl_writ(3), kt   
     abort_message=' Probleme dans prism_put_proto '
     call abort_gcm(modname,abort_message,1)
   endif
   call prism_put_proto(il_out_var_id(4), kt, fnsolwat, ierror)
   IF (ierror .ne. PRISM_Ok) THEN
     WRITE (nuout,*)  cl_writ(4), kt   
     abort_message=' Probleme dans prism_put_proto '
     call abort_gcm(modname,abort_message,1)
   endif
   call prism_put_proto(il_out_var_id(5), kt, fnsicedt, ierror)
   IF (ierror .ne. PRISM_Ok) THEN
     WRITE (nuout,*)  cl_writ(5), kt   
     abort_message=' Probleme dans prism_put_proto '
     call abort_gcm(modname,abort_message,1)
   endif
   call prism_put_proto(il_out_var_id(6), kt, evice, ierror)
   IF (ierror .ne. PRISM_Ok) THEN
     WRITE (nuout,*)  cl_writ(6), kt   
     abort_message=' Probleme dans prism_put_proto '
     call abort_gcm(modname,abort_message,1)
   endif
   call prism_put_proto(il_out_var_id(7), kt, evwat, ierror)
   IF (ierror .ne. PRISM_Ok) THEN
     WRITE (nuout,*)  cl_writ(7), kt   
     abort_message=' Probleme dans prism_put_proto '
     call abort_gcm(modname,abort_message,1)
   endif
   call prism_put_proto(il_out_var_id(8), kt, lpre, ierror)
   IF (ierror .ne. PRISM_Ok) THEN
     WRITE (nuout,*)  cl_writ(8), kt   
     abort_message=' Probleme dans prism_put_proto '
     call abort_gcm(modname,abort_message,1)
   endif
   call prism_put_proto(il_out_var_id(9), kt, spre, ierror)
   IF (ierror .ne. PRISM_Ok) THEN
     WRITE (nuout,*)  cl_writ(9), kt   
     abort_message=' Probleme dans prism_put_proto '
     call abort_gcm(modname,abort_message,1)
   endif
   call prism_put_proto(il_out_var_id(10), kt, dirunoff, ierror)
   IF (ierror .ne. PRISM_Ok) THEN
     WRITE (nuout,*)  cl_writ(10), kt   
     abort_message=' Probleme dans prism_put_proto '
     call abort_gcm(modname,abort_message,1)
   endif
   call prism_put_proto(il_out_var_id(11), kt, rivrunoff, ierror)
   IF (ierror .ne. PRISM_Ok) THEN
     WRITE (nuout,*)  cl_writ(11), kt   
     abort_message=' Probleme dans prism_put_proto '
     call abort_gcm(modname,abort_message,1)
   endif
   call prism_put_proto(il_out_var_id(12), kt, calving, ierror)
   IF (ierror .ne. PRISM_Ok) THEN
     WRITE (nuout,*)  cl_writ(12), kt   
     abort_message=' Probleme dans prism_put_proto '
     call abort_gcm(modname,abort_message,1)
   endif
   call prism_put_proto(il_out_var_id(13), kt, tauxx_u, ierror)
   IF (ierror .ne. PRISM_Ok) THEN
     WRITE (nuout,*)  cl_writ(13), kt   
     abort_message=' Probleme dans prism_put_proto '
     call abort_gcm(modname,abort_message,1)
   endif
   call prism_put_proto(il_out_var_id(14), kt, tauyy_u, ierror)
   IF (ierror .ne. PRISM_Ok) THEN
     WRITE (nuout,*)  cl_writ(14), kt   
     abort_message=' Probleme dans prism_put_proto '
     call abort_gcm(modname,abort_message,1)
   endif
   call prism_put_proto(il_out_var_id(15), kt, tauzz_u, ierror)
   IF (ierror .ne. PRISM_Ok) THEN
     WRITE (nuout,*)  cl_writ(15), kt   
     abort_message=' Probleme dans prism_put_proto '
     call abort_gcm(modname,abort_message,1)
   endif
   call prism_put_proto(il_out_var_id(16), kt, tauxx_v, ierror)
   IF (ierror .ne. PRISM_Ok) THEN
     WRITE (nuout,*)  cl_writ(16), kt   
     abort_message=' Probleme dans prism_put_proto '
     call abort_gcm(modname,abort_message,1)
   endif
   call prism_put_proto(il_out_var_id(17), kt, tauyy_v, ierror)
   IF (ierror .ne. PRISM_Ok) THEN
     WRITE (nuout,*)  cl_writ(17), kt   
     abort_message=' Probleme dans prism_put_proto '
     call abort_gcm(modname,abort_message,1)
   endif
   call prism_put_proto(il_out_var_id(18), kt, tauzz_v, ierror)
   IF (ierror .ne. PRISM_Ok) THEN
     WRITE (nuout,*)  cl_writ(18), kt   
     abort_message=' Probleme dans prism_put_proto '
     call abort_gcm(modname,abort_message,1)
   endif

   if (last) then
     call prism_terminate_proto(ierror)
     IF (ierror .ne. PRISM_Ok) THEN
       WRITE (nuout,*)  cl_writ(18), kt   
       abort_message=' Probleme dans prism_terminate_proto '
       call abort_gcm(modname,abort_message,1)
     endif
   endif


   RETURN
   END SUBROUTINE intocpl

   END MODULE oasis