ecearth3/sources/tm5mp/proj/ecearth/tmm_mf_prism.F90

!
#define TRACEBACK write (gol,'("in ",a," (",a,", line",i5,")")') rname, __FILE__, __LINE__; call goErr
!
#define IF_NOTOK_RETURN(action) if (status/=0) then; TRACEBACK; action; return; end if
#define IF_ERROR_RETURN(action) if (status >0) then; TRACEBACK; action; return; end if
!
#include "tm5.inc"
!
!-----------------------------------------------------------------------------
!                    TM5                                                     !
!-----------------------------------------------------------------------------
!BOP
!
! !MODULE:      TMM_MF_PRISM
!
! !DESCRIPTION:  Input/output of meteofiles : OASIS3/PRISM version.
!\\
!\\
! !INTERFACE: 
!
MODULE TMM_MF_PRISM
  !
  ! !USES:
  !
  use GO,           only : gol, goPr, goErr, goBug, goLabel, TDate
  use TM5_Prism,    only : TshRemap, comp_id
  use tm5_distgrid, only : dgrid, Get_DistGrid

  implicit none
  !
  ! !PUBLIC MEMBER FUNCTIONS:
  !
  public  :: cf_overhead                ! cloud fraction overhead
  public  :: mfPrism_Init, mfPrism_Done ! init/done tools for reading MF
  public  :: TMeteoFile_prism           ! MF type for reading prism meteo
  public  :: Init, Done, ReadRecord     ! methods for MF type
  !
  ! !PUBLIC DATA MEMBERS:
  !
  character(len=*), parameter  ::  mname = 'module tmm_mf_prism'
  !
  ! !PUBLIC TYPES:
  !
  type TMeteoFile_prism
     type(TDate)       ::  tday  ! reference date
  end type TMeteoFile_prism

  type(TshRemap), save ::  shRemap2d, shRemap3d
  real, pointer        ::  spinf2d_sh_raw(:,:,:)
  integer              ::  itim_readrecord  ! timer id
  !
  ! !INTERFACE:
  !
  interface Init
     module procedure mf_Init
  end interface

  interface Done
     module procedure mf_Done
  end interface

  interface ReadRecord
#ifdef parallel_cplng
     module procedure mf_ReadRecord_parallel
#else
     module procedure mf_ReadRecord
#endif
  end interface
  !
  ! !REVISION HISTORY: 
  !   16 Sep 2013 - Ph. Le Sager - doc, clean up, updated for TM5v4. Remove
  !                                oasis4 stuff for clarity.
  !
  ! !REMARKS:
  !
  !EOP
  !------------------------------------------------------------------------

CONTAINS

  !--------------------------------------------------------------------------
  !                    TM5                                                  !
  !--------------------------------------------------------------------------
  !BOP
  !
  ! !IROUTINE:    MFPRISM_INIT
  !
  ! !DESCRIPTION: Init tools for remapping spectral fields. Init timer.
  !\\
  !\\
  ! !INTERFACE:
  !
  SUBROUTINE MFPRISM_INIT( status )
    !
    ! !USES:
    !
    use GO,        only : NewDate, GO_Timer_Def
    use TM5_Prism, only : Init
    !
    ! !OUTPUT PARAMETERS:
    !
    integer, intent(out)         ::  status
    !
    ! !REMARKS:
    !
    !EOP
    !------------------------------------------------------------------------
    !BOC

    character(len=*), parameter  ::  rname = mname//'/mfPrism_Init'

    integer             ::  icache

    ! --- begin -----------------------------------------
    !
    ! spectral remapping
    !
    call Init( shRemap2d, status )
    IF_NOTOK_RETURN(status=1)  

    call Init( shRemap3d, status )
    IF_NOTOK_RETURN(status=1) 

    nullify( spinf2d_sh_raw )

    ! define timer (expected by tmm.F90)
    call GO_Timer_Def( itim_readrecord, 'tmm prism readrecord', status )
    IF_NOTOK_RETURN(status=1)

    status = 0

  END SUBROUTINE MFPRISM_INIT
  !EOC

  !--------------------------------------------------------------------------
  !                    TM5                                                  !
  !--------------------------------------------------------------------------
  !BOP
  !
  ! !IROUTINE:    MFPRISM_DONE
  !
  ! !DESCRIPTION: 
  !\\
  !\\
  ! !INTERFACE:
  !
  SUBROUTINE MFPRISM_DONE( status )
    !
    ! !USES:
    !
    use TM5_Prism, only : Done
    !
    ! !OUTPUT PARAMETERS:
    !
    integer, intent(out)         ::  status
    !
    ! !REMARKS:
    !
    !EOP
    !------------------------------------------------------------------------
    !BOC

    character(len=*), parameter  ::  rname = mname//'/mfPrism_Done'

    ! --- begin -----------------------------------------

    call Done( shRemap2d, status )
    IF_NOTOK_RETURN(status=1)  

    call Done( shRemap3d, status )
    IF_NOTOK_RETURN(status=1)  

    if ( associated(spinf2d_sh_raw) ) deallocate( spinf2d_sh_raw )

    status = 0

  END SUBROUTINE MFPRISM_DONE
  !EOC
  
  !--------------------------------------------------------------------------
  !                    TM5                                                  !
  !--------------------------------------------------------------------------
  !BOP
  !
  ! !IROUTINE:    MF_INIT
  !
  ! !DESCRIPTION: init an prism MF object
  !\\
  !\\
  ! !INTERFACE:
  !
  SUBROUTINE MF_INIT( mf, tday, status )
    !
    ! !USES:
    !
    use GO, only : TDate
    !
    ! !OUTPUT PARAMETERS:
    !
    type(TMeteoFile_prism), intent(out) ::  mf
    !
    ! !INPUT PARAMETERS:
    !
    type(TDate),            intent(in)  ::  tday
    integer,                intent(out) ::  status
    !
    ! !REMARKS:
    !
    !EOP
    !------------------------------------------------------------------------
    !BOC

    character(len=*), parameter  ::  rname = mname//'/mf_Init'

    ! --- begin --------------------------------

    mf%tday = tday

    status = 0

  END SUBROUTINE MF_INIT
  !EOC

  !--------------------------------------------------------------------------
  !                    TM5                                                  !
  !--------------------------------------------------------------------------
  !BOP
  !
  ! !IROUTINE:    MF_DONE
  !
  ! !DESCRIPTION: 
  !\\
  !\\
  ! !INTERFACE:
  !
  SUBROUTINE MF_DONE( mf, status )
    !
    ! !INPUT/OUTPUT PARAMETERS:
    !
    type(TMeteoFile_prism), intent(inout) ::  mf
    !
    ! !OUTPUT PARAMETERS:
    !
    integer,                intent(out)   ::  status
    !
    ! !REMARKS:
    !
    !EOP
    !------------------------------------------------------------------------
    !BOC

    character(len=*), parameter  ::  rname = mname//'/mf_Done'

    status = 0

  end subroutine mf_Done
  !EOC

  !--------------------------------------------------------------------------
  !                    TM5                                                  !
  !--------------------------------------------------------------------------
  !BOP
  !
  ! !IROUTINE:    MF_READRECORD
  !
  ! !DESCRIPTION: fill in met field with fields from OASIS3/PRISM coupler
  !\\
  !\\
  ! !INTERFACE:
  !
  subroutine mf_ReadRecord( mf, paramkey, t1, t2, nuv, nw, &
                                          gridtype, levi, &
                                          lli, ll, sp_ll, &
                                          ggi, gg, sp_gg, &
                                          shi, sh, lnsp_sh, &
                                          tmi, status )
    !
    ! !USES:
    !
    use parray,   only : pa_SetShape
    use GO,       only : TDate, wrtgol, IsAnyDate
    use GO,       only : operator(+), operator(-), operator(/), operator(==), operator(/=)
    use GO,       only : GO_Timer_Start, GO_Timer_End
    use Grid,     only : TllGridInfo, TggGridInfo, TshGridInfo, TLevelInfo
    use Grid,     only : Init, Set
    use tmm_info, only : TMeteoInfo, Init, AddHistory
    use binas,    only : grav

    use mod_oasis

    use TM5_Prism, only : SetPrismTime  
    use TM5_Prism, only : Setup, Remap
    use TM5_Prism, only : InqCplVar, CplVar
    !
    ! !INPUT/OUTPUT PARAMETERS:
    !
    type(TMeteoFile_prism), intent(inout) ::  mf
    !
    ! !INPUT PARAMETERS:
    !
    character(len=*),       intent(in)    ::  paramkey
    type(TDate),            intent(in)    ::  t1, t2
    character(len=1),       intent(in)    ::  nuv
    character(len=1),       intent(in)    ::  nw
    !
    ! !OUTPUT PARAMETERS:
    !
    character(len=2),       intent(out)   ::  gridtype
    type(TLevelInfo),       intent(out)   ::  levi

    type(TllGridInfo),      intent(inout) ::  lli
    real, pointer                         ::  ll(:,:,:)
    real, pointer                         ::  sp_ll(:,:)

    type(TggGridInfo),      intent(inout) ::  ggi
    real, pointer                         ::  gg(:,:)
    real, pointer                         ::  sp_gg(:)

    type(TshGridInfo),      intent(inout) ::  shi
    complex, pointer                      ::  sh(:,:)
    complex, pointer                      ::  lnsp_sh(:)

    type(TMeteoInfo),       intent(out)   ::  tmi
    integer,                intent(out)   ::  status
    !
    ! !REMARKS:
    !  (1) only root arrives here, called from tmm_mf/ReadRecord
    !
    !EOP
    !------------------------------------------------------------------------
    !BOC

    character(len=*), parameter  ::  rname = mname//'/mf_ReadRecord'

    ! value filled into spinf arrays to define not a number:    
    real, parameter           ::  spinf_nan = -1.2345

    ! --- local -----------------------------------

    type(TDate)               ::  tmid
    integer                           ::  prism_t
    real(ip_realwp_p), allocatable    ::  ifs_ll(:,:)
    real(ip_realwp_p), allocatable    ::  ifs_sp(:)
    integer                           ::  ilev
    integer                           ::  k

    real, allocatable         ::  sh_raw(:,:,:)
    real, allocatable         ::  sh_zcl(:,:,:)

    real, allocatable         ::  cc_col(:)
    real, allocatable         ::  cc_rev(:)
    real, allocatable         ::  cco_col(:)
    real, allocatable         ::  ccu_rev(:)
    integer                   ::  lme

    integer                   ::  ivar
    integer                   ::  ivar_cco, ivar_ccu
    integer                   ::  info

    real                      ::  tb_sec

    integer                   ::  icache

    integer                   ::  i,j,l
    character(len=256)  ::  error_message

    ! --- begin ---------------------------------

    call goLabel(rname)

    call GO_Timer_Start( itim_readrecord, status )
    IF_NOTOK_RETURN(status=1)

    ! no times defined in t1 and t2 ?
    if ( IsAnyDate(t1) .and. IsAnyDate(t2) ) then
       ! for constant fields (orography), t1 and t2 are any date;
       ! use the tday stored in mf structure for the orography time:
       tmid = mf%tday
    else
       ! in oasis3 always begin of interval:
       tmid = t1
    end if

    ! convert from tm5 time structure to prism time structure:
    call SetPrismTime( prism_t, tmid, status )
    IF_ERROR_RETURN(status=1)
    
    !write (gol,*) trim(rname)//' '// trim(paramkey); call goPr
    
    ! *************************** READ FIELD ******************************
    PARAM: SELECT CASE ( paramkey )

    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ! 3D lat/lon fields
    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~     
    ! Temperature, humidity, cloud fields, convective fluxes and detrainment rates
    ! Cloud details:
    ! CLWC   liquid water content (kg/kg) (halo=0)
    ! CIWC   ice water content (kg/kg) (halo=0)
    ! CC     cloud cover (fraction) (halo=0)

    case ( 'T', 'Q', 'CLWC', 'CIWC', 'CC', 'CCO','CCU', 'UDMF', 'DDMF', 'UDDR','DDDR' )

       call InqCplVar( paramkey, status, ivar=ivar )       ! inquire field number of coupled field
       IF_NOTOK_RETURN(status=1)

       gridtype = 'll'
       
       ! fill lli
       call Get_DistGrid( dgrid( CplVar(ivar)%region ), global_lli=lli )

       ! allocate arrays if necessary:
       call pa_SetShape( sp_ll, CplVar(ivar)%nlon, CplVar(ivar)%nlat )
       call pa_SetShape( ll   , CplVar(ivar)%nlon, CplVar(ivar)%nlat, CplVar(ivar)%nlev )

       ! ~~ SURFACE PRESSURE ~~

       ! inquire field number of coupled field:
       call InqCplVar( 'sp', status, ivar=ivar )
       IF_NOTOK_RETURN(status=1)

       ! in cache ?
       if ( CplVar(ivar)%cache_tmid == tmid ) then

         sp_ll = CplVar(ivar)%cache_data(:,:,1) ! copy from cache
         
         !write (gol,'(a,i3.3)') "       getting SP from CACHE, ivar=",ivar; call goPr

       else

          !write (gol,'(a,i3.3)') "       getting SP from OASIS, ivar=",ivar; call goPr
           
          ilev = 1
         allocate( ifs_ll(CplVar(ivar)%nlon,CplVar(ivar)%nlat) ) ! temporary storage with correct kind

         CALL OASIS_GET( CplVar(ivar)%var_id(ilev), prism_t, ifs_ll, status )
          
         SELECT CASE ( status )

         CASE (OASIS_Recvd, OASIS_FromRest, OASIS_Input, OASIS_RecvOut, OASIS_FromRestOut)
           CONTINUE

         CASE ( OASIS_OK )
           TRACEBACK
           WRITE (error_message,'("TMM_MF_PRISM: no exchange, while expected!")')
           CALL OASIS_ABORT( comp_id, rname, error_message )

         CASE DEFAULT
           TRACEBACK
           WRITE (error_message,'("TMM_MF_PRISM: Error in OASIS_GET:",i6)') status
           CALL OASIS_ABORT( comp_id, rname, error_message )

         END SELECT

         sp_ll = ifs_ll
         deallocate( ifs_ll )

         CplVar(ivar)%cache_tmid        = tmid ! store in cache
         CplVar(ivar)%cache_data(:,:,1) = sp_ll

       end if

       ! ~~ 3D FIELD ~~

       call InqCplVar( paramkey, status, ivar=ivar ) ! inquire field number of coupled field
       IF_NOTOK_RETURN(status=1)
       
       !write (gol,'(a,x,a,x,a,i3.3)') "       getting", trim(paramkey), "from OASIS, ivar=",ivar; call goPr

       ALLOCATE( ifs_ll(CplVar(ivar)%nlon,CplVar(ivar)%nlat) ) ! temporary storage with correct kind
       
       DO ilev = 1, CplVar(ivar)%nlev

         CALL OASIS_GET( CplVar(ivar)%var_id(ilev), prism_t, ifs_ll, status )

         SELECT CASE ( status )
           
         CASE (OASIS_Recvd, OASIS_FromRest, OASIS_Input, OASIS_RecvOut, OASIS_FromRestOut)
           CONTINUE

         CASE ( OASIS_OK )
           TRACEBACK
           WRITE (error_message,'("TMM_MF_PRISM: no exchange, while expected!")')
           CALL OASIS_ABORT( comp_id, rname, error_message )

         CASE DEFAULT
           TRACEBACK
           WRITE (error_message,'("TMM_MF_PRISM: Error in OASIS_GET:",i6)') status
           CALL OASIS_ABORT( comp_id, rname, error_message )

         END SELECT
         
         ll(:,:,CplVar(ivar)%nlev+1-ilev) = ifs_ll ! store; reverse layer order

       ENDDO
       DEALLOCATE( ifs_ll )

       ! convert ...
       select case ( paramkey )
       case ( 'Q'    ) ; ll = min( max( 0.0, ll ), 1.0 )   ! [0-1]
       case ( 'CLWC' ) ; ll = min( max( 0.0, ll ), 1.0 )   ! [0-1]
       case ( 'CIWC' ) ; ll = min( max( 0.0, ll ), 1.0 )   ! [0-1]
       case ( 'CC'   ) ; ll = min( max( 0.0, ll ), 1.0 )   ! [0-1] 
       case ( 'CCO'  ) ; ll = min( max( 0.0, ll ), 1.0 )   ! [0-1]
       case ( 'CCU'  ) ; ll = min( max( 0.0, ll ), 1.0 )   ! [0-1]
       end select

       ! evaluate CCO / CCU
       select case ( paramkey )
       case ( 'CCO'  )
          
          ! --- overhead cloud cover:
          lme = CplVar(ivar)%nlev
          allocate( cc_col(lme) )
          allocate( cco_col(lme) )

!          !$OMP PARALLEL
          do j = 1, CplVar(ivar)%nlat
             do i = 1, CplVar(ivar)%nlon
                ! cf_overhead requires CC in the reversed vertical order of IFS
                do l = 1, lme
                   cc_col(l) = ll(i,j,lme+1-l)
                enddo
                call cf_overhead ( lme, cc_col, cco_col )
                ! cf_overhead delivers CCO at layer base in the reversed vertical order of IFS
                do l = 1, lme
                   ll(i,j,l)=cco_col(lme+1-l)
                enddo
             end do
          end do
!          !$OMP END PARALLEL

          deallocate( cc_col)
          deallocate( cco_col)

       case ( 'CCU'  )

          ! --- underfeet cloud cover:
          lme = CplVar(ivar)%nlev
          allocate( cc_rev(lme) )
          allocate( ccu_rev(lme) )

!          !$OMP PARALLEL 
          do j = 1, CplVar(ivar)%nlat
             do i = 1, CplVar(ivar)%nlon
                ! for calculating CCU cf_overhead requires CC in the vertical order of TM5
                cc_rev = ll(i,j,:)
                call cf_overhead( lme, cc_rev, ccu_rev )
                ! cf_overhead delivers CCU at layer top in the vertical order of TM5
                ll(i,j,:)=ccu_rev
             end do
          end do
!          !$OMP END PARALLEL

          deallocate( cc_rev)
          deallocate( ccu_rev)

       end select

       ! ~~ levels ~~

       call InqCplVar( paramkey, status, ivar=ivar )
       IF_NOTOK_RETURN(status=1)

       ! level info: field is stored in tm level order after receiving
       select case ( CplVar(ivar)%nlev )
       case ( 19 )
          call Init( levi, 'tm19', status )
          IF_NOTOK_RETURN(status=1)
       case ( 31 )
          call Init( levi, 'tm31', status )
          IF_NOTOK_RETURN(status=1)
       case ( 34 )
          call Init( levi, 'tm34', status )
          IF_NOTOK_RETURN(status=1)
       case ( 40 )
          call Init( levi, 'tm40', status )
          IF_NOTOK_RETURN(status=1)
       case ( 60 )
          call Init( levi, 'tm60', status )
          IF_NOTOK_RETURN(status=1)
       case ( 62 )
          call Init( levi, 'tm62', status )
          IF_NOTOK_RETURN(status=1)
       case ( 91 )
          call Init( levi, 'tm91', status )
          IF_NOTOK_RETURN(status=1) 
       case default
          write (gol,'("unsupported ifs nlev : ",i4)') CplVar(ivar)%nlev; call goErr
          write (gol,'("in ",a)') rname; call goErr; status=1; return
       end select

     ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
     ! 2D surface fields
     ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
     case ( 'sshf', 'slhf', 'ewss', 'nsss', 'oro', 'lsm', &
          'albedo', 'sr', 'ci', 'sst', 'cp', 'lsp', 'sf', &
          'u10m', 'v10m', 'd2m', 't2m', 'ssr', 'skt', 'src', 'sd', 'swvl1', &
          'tv01', 'tv02', 'tv03', 'tv04', 'tv05', 'tv06', 'tv07', 'tv09', &
          'tv10', 'tv11', 'tv13', 'tv16', 'tv17', 'tv18', 'tv19', 'cvl', 'cvh'  )
       
       call InqCplVar( paramkey, status, ivar=ivar )
       IF_NOTOK_RETURN(status=1)
       gridtype = 'll'

       ! intialize lat/lon info:
       call Get_DistGrid( dgrid( CplVar(ivar)%region ), global_lli=lli )
              
       ! allocate arrays if necessary:
       call pa_SetShape( ll, CplVar(ivar)%nlon, CplVar(ivar)%nlat, 1 )

       allocate( ifs_ll(CplVar(ivar)%nlon,CplVar(ivar)%nlat) )
       ilev = 1
       !write (gol,'(a,x,a,x,a,i3.3)') "       getting", trim(paramkey), "from OASIS, ivar=",ivar; call goPr

       CALL OASIS_GET( CplVar(ivar)%var_id(ilev), prism_t, ifs_ll, status )
       SELECT CASE ( status )

       CASE (OASIS_Recvd, OASIS_FromRest, OASIS_Input, OASIS_RecvOut, OASIS_FromRestOut)
         CONTINUE

       CASE ( OASIS_OK )
         TRACEBACK
         WRITE (error_message,'("TMM_MF_PRISM: no exchange, while expected!")')
         CALL OASIS_ABORT( comp_id, rname, error_message )

       CASE DEFAULT
         TRACEBACK
         WRITE (error_message,'("TMM_MF_PRISM: Error in OASIS_GET:",i6)') status
         CALL OASIS_ABORT( comp_id, rname, error_message )

       END SELECT

       ll(:,:,1) = ifs_ll
       deallocate( ifs_ll )

       ! CONVERT
       select case ( paramkey )
         !case ( 'oro'  ) ; ll = ll/grav      ! m m/s2  ->  m   <-- oro is in m*m/s2
       case ( 'lsm'  )                                ; ll = min( max( 0.0, ll * 100.0 ), 100.0 )   ! 0-1     ->  %
       case ( 'albedo', 'ci', 'swvl1', 'cvl', 'cvh' ) ; ll = min( max( 0.0, ll ), 1.0 )   ! [0-1]
       case ( 'lsp', 'cp' )                           ; ll = max( 0.0, ll / 1000.0 )   ! mm/s    ->  m/s
       ! Snow depth is received as kg/m3, 
       ! and should be converted to height in m of water equivalent.
       ! The water density is here set to 1000. kg/m3.
       case ( 'sd', 'src'  )                          ; ll = max( 0.0, ll / 1000.0 )   ! mm    ->  m
       case ( 'sr', 'sf', 'ssr' )                     ; ll = max( 0.0, ll)
       case ( 'tv01', 'tv02', 'tv03', 'tv04', 'tv05', 'tv06', 'tv07', 'tv09', &
            'tv10', 'tv11', 'tv13', 'tv16', 'tv17', 'tv18', 'tv19' )
         ll = min( max( 0.0, ll ), 100.0 )   ! %
       end select
       
       ! * level info (dummy levels)
       call Init( levi, 1, (/0.0,0.0/), (/1.0,0.0/), status )
       IF_NOTOK_RETURN(status=1)

    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ! 2D spectral fields
    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    case ( 'LNSP' )

       call InqCplVar( 'spinf2d', status, ivar=ivar )
       IF_NOTOK_RETURN(status=1)

       gridtype = 'sh'

       ! intialize spherical harmonic field info:
       call Init( shi, CplVar(ivar)%shT, status )
       IF_NOTOK_RETURN(status=1)

       ! allocate array if necessary:
       call pa_SetShape( sh, CplVar(ivar)%shn, 1 )

       ! raw spectral field from coupler:
       allocate( sh_raw(CplVar(ivar)%shn_recv*2,1,1) )
       allocate( sh_zcl(2,CplVar(ivar)%shn,1) )

       ! * SPINF2D

       ! setup remapping if not done yet
       if ( shRemap2d%t /= tmid ) then       ! receive info field every time step

         call InqCplVar( 'spinf2d', status, ivar=ivar )
         IF_NOTOK_RETURN(status=1)

         allocate( ifs_sp(CplVar(ivar)%shn_recv*2) )
         ifs_sp = spinf_nan          ! fill with nan
         ilev = 1
         
         !write (gol,'(a,i3.3)') "       getting SPINF2D from OASIS, ivar=",ivar; call goPr

         call OASIS_Get( CplVar(ivar)%var_id(ilev), prism_t, ifs_sp, status )

         SELECT CASE ( status )

         CASE (OASIS_Recvd, OASIS_FromRest, OASIS_Input, OASIS_RecvOut, OASIS_FromRestOut)
           CONTINUE

         CASE ( OASIS_OK )
           TRACEBACK
           WRITE (error_message,'("TMM_MF_PRISM: no exchange, while expected!")')
           CALL OASIS_ABORT( comp_id, rname, error_message )

         CASE DEFAULT
           TRACEBACK
           WRITE (error_message,'("TMM_MF_PRISM: Error in OASIS_GET:",i6)') status
           CALL OASIS_ABORT( comp_id, rname, error_message )

         END SELECT

         sh_raw(:,1,1) = ifs_sp
         deallocate( ifs_sp )

         if ( .not. associated(spinf2d_sh_raw) ) allocate( spinf2d_sh_raw(CplVar(ivar)%shn_recv*2,1,1) )
         spinf2d_sh_raw = sh_raw

         call Setup( shRemap2d, sh_raw, spinf_nan, status ) ! setup remapping
         IF_NOTOK_RETURN(status=1)

         shRemap2d%t = tmid    ! store time

       end if

       ! * LNSP

       call InqCplVar( 'LNSP', status, ivar=ivar )
       IF_NOTOK_RETURN(status=1)

       if ( CplVar(ivar)%cache_tmid == tmid ) then ! in cache?

          sh_zcl = CplVar(ivar)%cache_data
          !write (gol,'(a,i3.3)') "       getting LNSP from CACHE, ivar=",ivar; call goPr

       else

          allocate( ifs_sp(CplVar(ivar)%shn_recv*2) )
          ifs_sp = spinf_nan
          ilev = 1
          !write (gol,'(a,i3.3)') "       getting LNSP from OASIS, ivar=",ivar; call goPr
          
          call OASIS_Get( CplVar(ivar)%var_id(ilev), prism_t, ifs_sp, status )
          SELECT CASE ( status )

          CASE (OASIS_Recvd, OASIS_FromRest, OASIS_Input, OASIS_RecvOut, OASIS_FromRestOut)
             CONTINUE

          CASE ( OASIS_OK )
             TRACEBACK
             WRITE (error_message,'("TMM_MF_PRISM: no exchange, while expected!")')
             CALL OASIS_ABORT( comp_id, rname, error_message )

          CASE DEFAULT
             TRACEBACK
             WRITE (error_message,'("TMM_MF_PRISM: Error in OASIS_GET:",i6)') status
             CALL OASIS_ABORT( comp_id, rname, error_message )

          END SELECT

          sh_raw(:,1,1) = ifs_sp
          deallocate( ifs_sp )

          call Remap( shRemap2d, sh_raw, shi, sh_zcl, status )
          IF_NOTOK_RETURN(status=1)

          CplVar(ivar)%cache_tmid = tmid
          CplVar(ivar)%cache_data = sh_zcl

       end if

       sh = cmplx(sh_zcl(1,:,:),sh_zcl(2,:,:))       ! convert to complex

       deallocate( sh_raw )
       deallocate( sh_zcl )

       ! * level info (dummy levels)
       call Init( levi, 1, (/0.0,0.0/), (/1.0,0.0/), status )
       IF_NOTOK_RETURN(status=1)

    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ! 3D spectral fields
    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    case ( 'VO', 'D' )

       call InqCplVar( paramkey, status, ivar=ivar )
       IF_NOTOK_RETURN(status=1)

       gridtype = 'sh'

       ! intialize spherical harmonic field info:
       call Init( shi, CplVar(ivar)%shT, status )
       IF_NOTOK_RETURN(status=1)

       ! allocate arrays if necessary:
       call pa_SetShape( sh     , CplVar(ivar)%shn, CplVar(ivar)%nlev )
       call pa_SetShape( lnsp_sh, CplVar(ivar)%shn )

       ! raw spectral field from coupler:
       allocate( sh_raw(CplVar(ivar)%shn_recv*2,CplVar(ivar)%nlev,1) )
       allocate( sh_zcl(2,CplVar(ivar)%shn,CplVar(ivar)%nlev) )

       ! * SPINF3D

       ! setup remapping if not done yet
       if ( shRemap3d%t /= tmid ) then

         sh_raw = spinf_nan

          ! use save field:
          do ilev = 1, CplVar(ivar)%nlev
             do k = 1, CplVar(ivar)%shn_recv*2
                if ( spinf2d_sh_raw(k,1,1) /= spinf_nan ) then
                   sh_raw(k,ilev,1) = spinf2d_sh_raw(k,1,1) + sign(ilev*0.01,spinf2d_sh_raw(k,1,1))
                end if
             end do
          end do

          call Setup( shRemap3d, sh_raw, spinf_nan, status )
          IF_NOTOK_RETURN(status=1)

          shRemap3d%t = tmid

       end if

       ! * 3D SPECTRAL FIELD

       call InqCplVar( paramkey, status, ivar=ivar )
       IF_NOTOK_RETURN(status=1)

       if ( CplVar(ivar)%cache_tmid == tmid ) then       ! in cache ?

          sh_zcl = CplVar(ivar)%cache_data
          !write (gol,'(a,x,a,x,a,i3.3)') "       getting", trim(paramkey), "from CACHE, ivar=",ivar; call goPr

       else

          allocate( ifs_sp(CplVar(ivar)%shn_recv*2) )          
          ifs_sp = spinf_nan
          !write (gol,'(a,x,a,x,a,i3.3)') "       getting", trim(paramkey), "from OASIS, ivar=",ivar; call goPr
          
          do ilev = 1, CplVar(ivar)%nlev
             
             CALL OASIS_GET( CplVar(ivar)%var_id(ilev), prism_t, ifs_sp, status )
             SELECT CASE ( status )

             CASE (OASIS_Recvd, OASIS_FromRest, OASIS_Input, OASIS_RecvOut, OASIS_FromRestOut)
               CONTINUE

             CASE ( OASIS_OK )
               TRACEBACK
               WRITE (error_message,'("TMM_MF_PRISM: no exchange, while expected!")')
               CALL OASIS_ABORT( comp_id, rname, error_message )

             CASE DEFAULT
               TRACEBACK
               WRITE (error_message,'("TMM_MF_PRISM: Error in OASIS_GET:",i6)') status
               CALL OASIS_ABORT( comp_id, rname, error_message )

             END SELECT

             sh_raw(:,ilev,1) = ifs_sp

          end do

          deallocate( ifs_sp )

          call Remap( shRemap3d, sh_raw, shi, sh_zcl, status )
          IF_NOTOK_RETURN(status=1)

          CplVar(ivar)%cache_tmid = tmid
          CplVar(ivar)%cache_data = sh_zcl

       end if

       ! convert to complex:
       sh = cmplx(sh_zcl(1,:,:),sh_zcl(2,:,:))

       ! * LNSP

       call InqCplVar( 'LNSP', status, ivar=ivar )
       IF_NOTOK_RETURN(status=1)

       ! copy from cache:
       lnsp_sh = cmplx(CplVar(ivar)%cache_data(1,:,1),CplVar(ivar)%cache_data(2,:,1))

       deallocate( sh_raw )
       deallocate( sh_zcl )

       ! * level info

       call InqCplVar( paramkey, status, ivar=ivar )
       IF_NOTOK_RETURN(status=1)

       ! gridless fields are received in original ec order!
       select case ( CplVar(ivar)%nlev )
       case ( 19 )
          call Init( levi, 'ec19', status )
          IF_NOTOK_RETURN(status=1)
       case ( 31 )
          call Init( levi, 'ec31', status )
          IF_NOTOK_RETURN(status=1)
       case ( 34 )
          call Init( levi, 'ec34', status )
          IF_NOTOK_RETURN(status=1)
       case ( 40 )
          call Init( levi, 'ec40', status )
          IF_NOTOK_RETURN(status=1)
       case ( 60 )
          call Init( levi, 'ec60', status )
          IF_NOTOK_RETURN(status=1)
       case ( 62 )
          call Init( levi, 'ec62', status )
          IF_NOTOK_RETURN(status=1)
       case ( 91 )
          call Init( levi, 'ec91', status )
          IF_NOTOK_RETURN(status=1)
       case default
          write (gol,'("unsupported ifs nlev : ",i4)') CplVar(ivar)%nlev; call goErr
          write (gol,'("in ",a)') rname; call goErr; status=1; return
       end select

    case default
       write (gol,'("unsupported paramkey `",a,"`")') trim(paramkey); call goErr
       write (gol,'("in ",a)') rname; status=1; return; call goErr

    END SELECT PARAM

    ! fill some info values
    call Init( tmi, paramkey, 'unkown', status )
    call AddHistory( tmi, 'model==oasis_coupler', status )

    call GO_Timer_End( itim_readrecord, status )
    IF_NOTOK_RETURN(status=1)
    call goLabel()
    status = 0

  end subroutine mf_ReadRecord
  !EOC

  subroutine mf_ReadRecord_parallel( mf, paramkey, t1, t2, nuv, nw, &
       gridtype, levi, &
       lli, ll, sp_ll, &
       ggi, gg, sp_gg, &
       shi, sh, lnsp_sh, &
       tmi, status )
    !
    ! !USES:
    !
    use parray,   only : pa_SetShape
    use GO,       only : TDate, wrtgol, IsAnyDate
    use GO,       only : operator(+), operator(-), operator(/), operator(==), operator(/=)
    use GO,       only : GO_Timer_Start, GO_Timer_End
    use Grid,     only : TllGridInfo, TggGridInfo, TshGridInfo, TLevelInfo
    use Grid,     only : Init, Set
    use tmm_info, only : TMeteoInfo, Init, AddHistory
    use binas,    only : grav

    use mod_oasis

    use TM5_Prism, only : SetPrismTime  
    use TM5_Prism, only : Setup, Remap
    use TM5_Prism, only : InqCplVar, CplVar
    !
    ! !INPUT/OUTPUT PARAMETERS:
    !
    type(TMeteoFile_prism), intent(inout) ::  mf
    !
    ! !INPUT PARAMETERS:
    !
    character(len=*),       intent(in)    ::  paramkey
    type(TDate),            intent(in)    ::  t1, t2
    character(len=1),       intent(in)    ::  nuv
    character(len=1),       intent(in)    ::  nw
    !
    ! !OUTPUT PARAMETERS:
    !
    character(len=2),       intent(out)   ::  gridtype
    type(TLevelInfo),       intent(out)   ::  levi

    type(TllGridInfo),      intent(inout) ::  lli
    real, pointer                         ::  ll(:,:,:)
    real, pointer                         ::  sp_ll(:,:)

    type(TggGridInfo),      intent(inout) ::  ggi
    real, pointer                         ::  gg(:,:)
    real, pointer                         ::  sp_gg(:)

    type(TshGridInfo),      intent(inout) ::  shi
    complex, pointer                      ::  sh(:,:)
    complex, pointer                      ::  lnsp_sh(:)

    type(TMeteoInfo),       intent(out)   ::  tmi
    integer,                intent(out)   ::  status
    !
    ! !REMARKS:
    !
    !EOP
    !------------------------------------------------------------------------
    !BOC

    character(len=*), parameter  ::  rname = mname//'/mf_ReadRecord_parallel'

    ! value filled into spinf arrays to define not a number:    
    real, parameter           ::  spinf_nan = -1.2345

    ! --- local -----------------------------------

    type(TDate)               ::  tmid
    integer                           ::  prism_t
    real(ip_realwp_p), allocatable    ::  ifs_ll(:,:)
    real(ip_realwp_p), allocatable    ::  ifs_sp(:)
    integer                           ::  ilev
    integer                           ::  k

    real, allocatable         ::  sh_raw(:,:,:)
    real, allocatable         ::  sh_zcl(:,:,:)

    real, allocatable         ::  cc_col(:)
    real, allocatable         ::  cc_rev(:)
    real, allocatable         ::  cco_col(:)
    real, allocatable         ::  ccu_rev(:)
    integer                   ::  lme

    integer                   ::  ivar
    integer                   ::  ivar_cco, ivar_ccu
    integer                   ::  info

    real                      ::  tb_sec

    integer                   ::  icache

    integer                   ::  i,j,l
    character(len=256)  ::  error_message

    ! --- begin ---------------------------------

    call goLabel(rname)

    call GO_Timer_Start( itim_readrecord, status )
    IF_NOTOK_RETURN(status=1)

    ! no times defined in t1 and t2 ?
    if ( IsAnyDate(t1) .and. IsAnyDate(t2) ) then
       ! for constant fields (orography), t1 and t2 are any date;
       ! use the tday stored in mf structure for the orography time:
       tmid = mf%tday
    else
       ! in oasis3 always begin of interval:
       tmid = t1
    end if

    ! convert from tm5 time structure to prism time structure:
    call SetPrismTime( prism_t, tmid, status )
    IF_ERROR_RETURN(status=1)

    ! *************************** READ FIELD ******************************
    PARAM: SELECT CASE ( paramkey )

       ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
       ! 3D lat/lon fields
       ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~     
       ! Temperature, humidity, cloud fields, convective fluxes and detrainment rates
       ! Cloud details:
       ! CLWC   liquid water content (kg/kg) (halo=0)
       ! CIWC   ice water content (kg/kg) (halo=0)
       ! CC     cloud cover (fraction) (halo=0)

    case ( 'T', 'Q', 'CLWC', 'CIWC', 'CC', 'CCO','CCU', 'UDMF', 'DDMF', 'UDDR','DDDR' )

       call InqCplVar( paramkey, status, ivar=ivar )       ! inquire field number of coupled field
       IF_NOTOK_RETURN(status=1)

       gridtype = 'll'

       ! intialize lat/lon info:
       call Get_DistGrid( dgrid( CplVar(ivar)%region ), lli=lli )
       
       ! allocate arrays if necessary:
       call pa_SetShape( sp_ll, CplVar(ivar)%nlon, CplVar(ivar)%nlat )
       call pa_SetShape( ll   , CplVar(ivar)%nlon, CplVar(ivar)%nlat, CplVar(ivar)%nlev )

       ! ~~ SURFACE PRESSURE ~~

       ! inquire field number of coupled field:
       call InqCplVar( 'sp', status, ivar=ivar )
       IF_NOTOK_RETURN(status=1)

       ! in cache ?
       if ( CplVar(ivar)%cache_tmid == tmid ) then

          sp_ll = CplVar(ivar)%cache_data(:,:,1) ! copy from cache

       else

          ! Are we really ever getting here???? Looks like SP is computed from LNSP
          
          ilev = 1
          allocate( ifs_ll(CplVar(ivar)%nlon,CplVar(ivar)%nlat) ) ! temporary storage with correct kind

          CALL OASIS_GET( CplVar(ivar)%var_id(ilev), prism_t, ifs_ll, status )

          SELECT CASE ( status )

          CASE (OASIS_Recvd, OASIS_FromRest, OASIS_Input, OASIS_RecvOut, OASIS_FromRestOut)
             CONTINUE

          CASE ( OASIS_OK )
             TRACEBACK
             WRITE (error_message,'("TMM_MF_PRISM: no exchange, while expected!")')
             CALL OASIS_ABORT( comp_id, rname, error_message )

          CASE DEFAULT
             TRACEBACK
             WRITE (error_message,'("TMM_MF_PRISM: Error in OASIS_GET:",i6)') status
             CALL OASIS_ABORT( comp_id, rname, error_message )

          END SELECT

          sp_ll = ifs_ll
          deallocate( ifs_ll )

          CplVar(ivar)%cache_tmid        = tmid ! store in cache
          CplVar(ivar)%cache_data(:,:,1) = sp_ll

       end if

       ! ~~ 3D FIELD ~~

       call InqCplVar( paramkey, status, ivar=ivar ) ! inquire field number of coupled field
       IF_NOTOK_RETURN(status=1)

       ALLOCATE( ifs_ll(CplVar(ivar)%nlon,CplVar(ivar)%nlat) ) ! temporary storage with correct kind

       DO ilev = 1, CplVar(ivar)%nlev

          CALL OASIS_GET( CplVar(ivar)%var_id(ilev), prism_t, ifs_ll, status )

          SELECT CASE ( status )

          CASE (OASIS_Recvd, OASIS_FromRest, OASIS_Input, OASIS_RecvOut, OASIS_FromRestOut)
             CONTINUE

          CASE ( OASIS_OK )
             TRACEBACK
             WRITE (error_message,'("TMM_MF_PRISM: no exchange, while expected!")')
             CALL OASIS_ABORT( comp_id, rname, error_message )

          CASE DEFAULT
             TRACEBACK
             WRITE (error_message,'("TMM_MF_PRISM: Error in OASIS_GET:",i6)') status
             CALL OASIS_ABORT( comp_id, rname, error_message )

          END SELECT

          ll(:,:,CplVar(ivar)%nlev+1-ilev) = ifs_ll ! store; reverse layer order

       ENDDO
       DEALLOCATE( ifs_ll )

       ! convert ...
       select case ( paramkey )
       case ( 'Q'    ) ; ll = min( max( 0.0, ll ), 1.0 )   ! [0-1]
       case ( 'CLWC' ) ; ll = min( max( 0.0, ll ), 1.0 )   ! [0-1]
       case ( 'CIWC' ) ; ll = min( max( 0.0, ll ), 1.0 )   ! [0-1]
       case ( 'CC'   ) ; ll = min( max( 0.0, ll ), 1.0 )   ! [0-1] 
       case ( 'CCO'  ) ; ll = min( max( 0.0, ll ), 1.0 )   ! [0-1]
       case ( 'CCU'  ) ; ll = min( max( 0.0, ll ), 1.0 )   ! [0-1]
       end select

       ! evaluate CCO / CCU
       select case ( paramkey )
       case ( 'CCO'  )

          ! --- overhead cloud cover:
          lme = CplVar(ivar)%nlev
          allocate( cc_col(lme) )
          allocate( cco_col(lme) )

          !          !$OMP PARALLEL
          do j = 1, CplVar(ivar)%nlat
             do i = 1, CplVar(ivar)%nlon
                ! cf_overhead requires CC in the reversed vertical order of IFS
                do l = 1, lme
                   cc_col(l) = ll(i,j,lme+1-l)
                enddo
                call cf_overhead ( lme, cc_col, cco_col )
                ! cf_overhead delivers CCO at layer base in the reversed vertical order of IFS
                do l = 1, lme
                   ll(i,j,l)=cco_col(lme+1-l)
                enddo
             end do
          end do
          !          !$OMP END PARALLEL

          deallocate( cc_col)
          deallocate( cco_col)

       case ( 'CCU'  )

          ! --- underfeet cloud cover:
          lme = CplVar(ivar)%nlev
          allocate( cc_rev(lme) )
          allocate( ccu_rev(lme) )

          !          !$OMP PARALLEL 
          do j = 1, CplVar(ivar)%nlat
             do i = 1, CplVar(ivar)%nlon
                ! for calculating CCU cf_overhead requires CC in the vertical order of TM5
                cc_rev = ll(i,j,:)
                call cf_overhead( lme, cc_rev, ccu_rev )
                ! cf_overhead delivers CCU at layer top in the vertical order of TM5
                ll(i,j,:)=ccu_rev
             end do
          end do
          !          !$OMP END PARALLEL

          deallocate( cc_rev)
          deallocate( ccu_rev)

       end select

       ! ~~ levels ~~

       call InqCplVar( paramkey, status, ivar=ivar )
       IF_NOTOK_RETURN(status=1)

       ! level info: field is stored in tm level order after receiving
       select case ( CplVar(ivar)%nlev )
       case ( 19 )
          call Init( levi, 'tm19', status )
          IF_NOTOK_RETURN(status=1)
       case ( 31 )
          call Init( levi, 'tm31', status )
          IF_NOTOK_RETURN(status=1)
       case ( 34 )
          call Init( levi, 'tm34', status )
          IF_NOTOK_RETURN(status=1)
       case ( 40 )
          call Init( levi, 'tm40', status )
          IF_NOTOK_RETURN(status=1)
       case ( 60 )
          call Init( levi, 'tm60', status )
          IF_NOTOK_RETURN(status=1)
       case ( 62 )
          call Init( levi, 'tm62', status )
          IF_NOTOK_RETURN(status=1)
       case ( 91 )
          call Init( levi, 'tm91', status )
          IF_NOTOK_RETURN(status=1) 
       case default
          write (gol,'("unsupported ifs nlev : ",i4)') CplVar(ivar)%nlev; call goErr
          write (gol,'("in ",a)') rname; call goErr; status=1; return
       end select

       ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
       ! 2D surface fields
       ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    case ( 'sshf', 'slhf', 'ewss', 'nsss', 'oro', 'lsm', &
         'albedo', 'sr', 'ci', 'sst', 'cp', 'lsp', 'sf', &
         'u10m', 'v10m', 'd2m', 't2m', 'ssr', 'skt', 'src', 'sd', 'swvl1', &
         'tv01', 'tv02', 'tv03', 'tv04', 'tv05', 'tv06', 'tv07', 'tv09', &
         'tv10', 'tv11', 'tv13', 'tv16', 'tv17', 'tv18', 'tv19', 'cvl', 'cvh'  )

       call InqCplVar( paramkey, status, ivar=ivar )
       IF_NOTOK_RETURN(status=1)
       gridtype = 'll'

       ! intialize lat/lon info:
       call Get_DistGrid( dgrid( CplVar(ivar)%region ), lli=lli )

       ! allocate arrays if necessary:
       call pa_SetShape( ll, CplVar(ivar)%nlon, CplVar(ivar)%nlat, 1 )

       allocate( ifs_ll(CplVar(ivar)%nlon,CplVar(ivar)%nlat) )
       ilev = 1

       CALL OASIS_GET( CplVar(ivar)%var_id(ilev), prism_t, ifs_ll, status )
       SELECT CASE ( status )

       CASE (OASIS_Recvd, OASIS_FromRest, OASIS_Input, OASIS_RecvOut, OASIS_FromRestOut)
          CONTINUE

       CASE ( OASIS_OK )
          TRACEBACK
          WRITE (error_message,'("TMM_MF_PRISM: no exchange, while expected!")')
          CALL OASIS_ABORT( comp_id, rname, error_message )

       CASE DEFAULT
          TRACEBACK
          WRITE (error_message,'("TMM_MF_PRISM: Error in OASIS_GET:",i6)') status
          CALL OASIS_ABORT( comp_id, rname, error_message )

       END SELECT

       ll(:,:,1) = ifs_ll
       deallocate( ifs_ll )

       ! CONVERT
       select case ( paramkey )
          !case ( 'oro'  ) ; ll = ll/grav      ! m m/s2  ->  m   <-- oro is in m*m/s2
       case ( 'lsm'  )                                ; ll = min( max( 0.0, ll * 100.0 ), 100.0 )   ! 0-1     ->  %
       case ( 'albedo', 'ci', 'swvl1', 'cvl', 'cvh' ) ; ll = min( max( 0.0, ll ), 1.0 )   ! [0-1]
       case ( 'lsp', 'cp' )                           ; ll = max( 0.0, ll / 1000.0 )   ! mm/s    ->  m/s
          ! Snow depth is received as kg/m3, 
          ! and should be converted to height in m of water equivalent.
          ! The water density is here set to 1000. kg/m3.
       case ( 'sd', 'src'  )                          ; ll = max( 0.0, ll / 1000.0 )   ! mm    ->  m
       case ( 'sr', 'sf', 'ssr' )                     ; ll = max( 0.0, ll)
       case ( 'tv01', 'tv02', 'tv03', 'tv04', 'tv05', 'tv06', 'tv07', 'tv09', &
            'tv10', 'tv11', 'tv13', 'tv16', 'tv17', 'tv18', 'tv19' )
          ll = min( max( 0.0, ll ), 100.0 )   ! %
       end select

       ! * level info (dummy levels)
       call Init( levi, 1, (/0.0,0.0/), (/1.0,0.0/), status )
       IF_NOTOK_RETURN(status=1)

       ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
       ! 2D spectral fields
       ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    case ( 'LNSP' )

       call InqCplVar( 'spinf2d', status, ivar=ivar )
       IF_NOTOK_RETURN(status=1)

       gridtype = 'sh'

       ! intialize spherical harmonic field info:
       call Init( shi, CplVar(ivar)%shT, status )
       IF_NOTOK_RETURN(status=1)

       ! allocate array if necessary:
       call pa_SetShape( sh, CplVar(ivar)%shn, 1 )

       ! raw spectral field from coupler:
       allocate( sh_raw(CplVar(ivar)%shn_recv*2,1,1) )
       allocate( sh_zcl(2,CplVar(ivar)%shn,1) )

       ! * SPINF2D

       ! setup remapping if not done yet
       if ( shRemap2d%t /= tmid ) then       ! receive info field every time step

          call InqCplVar( 'spinf2d', status, ivar=ivar )
          IF_NOTOK_RETURN(status=1)

          allocate( ifs_sp(CplVar(ivar)%shn_recv*2) )
          ifs_sp = spinf_nan          ! fill with nan
          ilev = 1

          call OASIS_Get( CplVar(ivar)%var_id(ilev), prism_t, ifs_sp, status )

          SELECT CASE ( status )

          CASE (OASIS_Recvd, OASIS_FromRest, OASIS_Input, OASIS_RecvOut, OASIS_FromRestOut)
             CONTINUE

          CASE ( OASIS_OK )
             TRACEBACK
             WRITE (error_message,'("TMM_MF_PRISM: no exchange, while expected!")')
             CALL OASIS_ABORT( comp_id, rname, error_message )

          CASE DEFAULT
             TRACEBACK
             WRITE (error_message,'("TMM_MF_PRISM: Error in OASIS_GET:",i6)') status
             CALL OASIS_ABORT( comp_id, rname, error_message )

          END SELECT

          sh_raw(:,1,1) = ifs_sp
          deallocate( ifs_sp )

          if ( .not. associated(spinf2d_sh_raw) ) allocate( spinf2d_sh_raw(CplVar(ivar)%shn_recv*2,1,1) )
          spinf2d_sh_raw = sh_raw

          call Setup( shRemap2d, sh_raw, spinf_nan, status ) ! setup remapping
          IF_NOTOK_RETURN(status=1)

          shRemap2d%t = tmid    ! store time

       end if

       ! * LNSP

       call InqCplVar( 'LNSP', status, ivar=ivar )
       IF_NOTOK_RETURN(status=1)

       if ( CplVar(ivar)%cache_tmid == tmid ) then ! in cache?

          sh_zcl = CplVar(ivar)%cache_data

       else

          allocate( ifs_sp(CplVar(ivar)%shn_recv*2) )
          ifs_sp = spinf_nan
          ilev = 1

          call OASIS_Get( CplVar(ivar)%var_id(ilev), prism_t, ifs_sp, status )
          SELECT CASE ( status )

          CASE (OASIS_Recvd, OASIS_FromRest, OASIS_Input, OASIS_RecvOut, OASIS_FromRestOut)
             CONTINUE

          CASE ( OASIS_OK )
             TRACEBACK
             WRITE (error_message,'("TMM_MF_PRISM: no exchange, while expected!")')
             CALL OASIS_ABORT( comp_id, rname, error_message )

          CASE DEFAULT
             TRACEBACK
             WRITE (error_message,'("TMM_MF_PRISM: Error in OASIS_GET:",i6)') status
             CALL OASIS_ABORT( comp_id, rname, error_message )

          END SELECT

          sh_raw(:,1,1) = ifs_sp
          deallocate( ifs_sp )

          call Remap( shRemap2d, sh_raw, shi, sh_zcl, status )
          IF_NOTOK_RETURN(status=1)

          CplVar(ivar)%cache_tmid = tmid
          CplVar(ivar)%cache_data = sh_zcl

       end if

       sh = cmplx(sh_zcl(1,:,:),sh_zcl(2,:,:))       ! convert to complex

       deallocate( sh_raw )
       deallocate( sh_zcl )

       ! * level info (dummy levels)
       call Init( levi, 1, (/0.0,0.0/), (/1.0,0.0/), status )
       IF_NOTOK_RETURN(status=1)

       ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
       ! 3D spectral fields
       ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    case ( 'VO', 'D' )

       call InqCplVar( paramkey, status, ivar=ivar )
       IF_NOTOK_RETURN(status=1)

       gridtype = 'sh'

       ! intialize spherical harmonic field info:
       call Init( shi, CplVar(ivar)%shT, status )
       IF_NOTOK_RETURN(status=1)

       ! allocate arrays if necessary:
       call pa_SetShape( sh     , CplVar(ivar)%shn, CplVar(ivar)%nlev )
       call pa_SetShape( lnsp_sh, CplVar(ivar)%shn )

       ! raw spectral field from coupler:
       allocate( sh_raw(CplVar(ivar)%shn_recv*2,CplVar(ivar)%nlev,1) )
       allocate( sh_zcl(2,CplVar(ivar)%shn,CplVar(ivar)%nlev) )

       ! * SPINF3D

       ! setup remapping if not done yet
       if ( shRemap3d%t /= tmid ) then

          sh_raw = spinf_nan

          ! use save field:
          do ilev = 1, CplVar(ivar)%nlev
             do k = 1, CplVar(ivar)%shn_recv*2
                if ( spinf2d_sh_raw(k,1,1) /= spinf_nan ) then
                   sh_raw(k,ilev,1) = spinf2d_sh_raw(k,1,1) + sign(ilev*0.01,spinf2d_sh_raw(k,1,1))
                end if
             end do
          end do

          call Setup( shRemap3d, sh_raw, spinf_nan, status )
          IF_NOTOK_RETURN(status=1)

          shRemap3d%t = tmid

       end if

       ! * 3D SPECTRAL FIELD

       call InqCplVar( paramkey, status, ivar=ivar )
       IF_NOTOK_RETURN(status=1)

       if ( CplVar(ivar)%cache_tmid == tmid ) then       ! in cache ?

          sh_zcl = CplVar(ivar)%cache_data

       else

          allocate( ifs_sp(CplVar(ivar)%shn_recv*2) )          
          ifs_sp = spinf_nan

          do ilev = 1, CplVar(ivar)%nlev

             CALL OASIS_GET( CplVar(ivar)%var_id(ilev), prism_t, ifs_sp, status )
             SELECT CASE ( status )

             CASE (OASIS_Recvd, OASIS_FromRest, OASIS_Input, OASIS_RecvOut, OASIS_FromRestOut)
                CONTINUE

             CASE ( OASIS_OK )
                TRACEBACK
                WRITE (error_message,'("TMM_MF_PRISM: no exchange, while expected!")')
                CALL OASIS_ABORT( comp_id, rname, error_message )

             CASE DEFAULT
                TRACEBACK
                WRITE (error_message,'("TMM_MF_PRISM: Error in OASIS_GET:",i6)') status
                CALL OASIS_ABORT( comp_id, rname, error_message )

             END SELECT

             sh_raw(:,ilev,1) = ifs_sp

          end do

          deallocate( ifs_sp )

          call Remap( shRemap3d, sh_raw, shi, sh_zcl, status )
          IF_NOTOK_RETURN(status=1)

          CplVar(ivar)%cache_tmid = tmid
          CplVar(ivar)%cache_data = sh_zcl

       end if

       ! convert to complex:
       sh = cmplx(sh_zcl(1,:,:),sh_zcl(2,:,:))

       ! * LNSP

       call InqCplVar( 'LNSP', status, ivar=ivar )
       IF_NOTOK_RETURN(status=1)

       ! copy from cache:
       lnsp_sh = cmplx(CplVar(ivar)%cache_data(1,:,1),CplVar(ivar)%cache_data(2,:,1))

       deallocate( sh_raw )
       deallocate( sh_zcl )

       ! * level info

       call InqCplVar( paramkey, status, ivar=ivar )
       IF_NOTOK_RETURN(status=1)

       ! gridless fields are received in original ec order!
       select case ( CplVar(ivar)%nlev )
       case ( 19 )
          call Init( levi, 'ec19', status )
          IF_NOTOK_RETURN(status=1)
       case ( 31 )
          call Init( levi, 'ec31', status )
          IF_NOTOK_RETURN(status=1)
       case ( 34 )
          call Init( levi, 'ec34', status )
          IF_NOTOK_RETURN(status=1)
       case ( 40 )
          call Init( levi, 'ec40', status )
          IF_NOTOK_RETURN(status=1)
       case ( 60 )
          call Init( levi, 'ec60', status )
          IF_NOTOK_RETURN(status=1)
       case ( 62 )
          call Init( levi, 'ec62', status )
          IF_NOTOK_RETURN(status=1)
       case ( 91 )
          call Init( levi, 'ec91', status )
          IF_NOTOK_RETURN(status=1)
       case default
          write (gol,'("unsupported ifs nlev : ",i4)') CplVar(ivar)%nlev; call goErr
          write (gol,'("in ",a)') rname; call goErr; status=1; return
       end select

    case default
       write (gol,'("unsupported paramkey `",a,"`")') trim(paramkey); call goErr
       write (gol,'("in ",a)') rname; status=1; return; call goErr

    END SELECT PARAM

    ! fill some info values
    call Init( tmi, paramkey, 'unkown', status )
    call AddHistory( tmi, 'model==oasis_coupler', status )

    call GO_Timer_End( itim_readrecord, status )
    IF_NOTOK_RETURN(status=1)
    call goLabel()
    status = 0

  end subroutine mf_ReadRecord_parallel


  
  !--------------------------------------------------------------------------
  !                    TM5                                                  !
  !--------------------------------------------------------------------------
  !BOP
  !
  ! !IROUTINE:    CF_OVERHEAD
  !
  ! !DESCRIPTION:
  !
  ! Calculate total cloud fraction overhead the base of each layer
  ! based on random/maximum overlap assumptions
  ! Based on code provided by Rob van Dorland
  ! 
  ! Input:
  !   nlev  : number of vertical levels
  !   yclfr : cloud fraction (cc) per cell (0-1)
  !
  ! Output:
  !   wccro: overhead cloud fraction
  !
  ! Optional arguments:
  !   scheme='ecmwf'  : 'ecmwf' -> iovln=1
  !                     'other' -> iovln=0
  !   eps=1.0e-4      : cltres
  !
  ! Parameters:
  !   iovln : switch
  !     1 = ecmwf (maximum random overlap assumption) scheme
  !     0 = another scheme
  !   cltres : threshold (minimum) cloud fraction used
  !            for numerical stability (division by zero
  !            and to eliminate small unrealistic cloud fractions
  !
  ! Notes:
  ! - Index=1 of arrays (yclfr) corresponds to model top
  ! - The clouds are supposed to be distributed homogeneously
  !   in the vertical in each layer.
  !
  !\\
  !\\
  ! !INTERFACE:
  !
  SUBROUTINE CF_OVERHEAD( nlev, yclfr, wccro, scheme, eps )
    !
    ! !INPUT PARAMETERS:
    !
    integer,          intent(in)           ::  nlev
    real,             intent(in)           ::  yclfr(nlev)
    !
    ! !OUTPUT PARAMETERS:
    !
    real,             intent(out)          ::  wccro(nlev)
    !
    ! !OPTIONAL INPUT PARAMETERS:
    !
    character(len=*), intent(in), optional ::  scheme
    real,             intent(in), optional ::  eps
    !
    ! !REVISION HISTORY: 
    !   Peter van Velthoven - 22 nov 2002
    !   Arjo Segers         - 25 nov 2002 - Optional arguments
    !   Vincent Huijnen     - 27 may 2002 - Applied in TM5-IFS coupled code
    !
    ! !REMARKS:
    !
    !EOP
    !------------------------------------------------------------------------
    !BOC

    real      ::   clfr0, clfr1, clfr2, ctver
    real      ::   zclear, zcloud
    integer   ::   jk

    ! --- settings -----------------------------

    integer    ::  iovln = 1      ! ecmwf; maximum random overlap
    real       ::  cltres = 1.0e-4

    ! --- begin -----------------------------

    if ( present(scheme) ) then
       select case ( scheme )
       case ( 'ecmwf' )
          iovln = 1
       case ( 'other' )
          iovln = 0
       case default
          print *, 'Unsupported scheme "'//scheme//'".'
          stop 'FATAL BUG IN cf_overhead'
       end select
    end if

    if ( present(eps) ) cltres = eps

    select case ( iovln )
    case ( 0 )
       !-----------------------------------------
       ! scheme 0: maximum overlap unless there's a
       ! clear sky layer in between?
       !-----------------------------------------

       clfr0 = 0.0
       clfr2 = 0.0
       ctver = 1.0
       do jk = 1, nlev
          clfr1 = yclfr(jk)
          if ( clfr1 < cltres ) then
             !----------------
             ! random overlap
             !----------------
             ctver = ctver * ( 1.0 - clfr2 )
             clfr2 = 0.0
          else
             if ( clfr0 < cltres ) then
                clfr2 = clfr1
             else
                !----------------
                ! maximum overlap
                !----------------
                clfr2 = max( clfr1,clfr2 )
             end if
          end if
          clfr0 = clfr1
          wccro(jk) = 1.0 - ctver * ( 1.0 - clfr2 )
       end do
       !ctver=ctver*(1.-clfr2)
       !wccro=1.-ctver

    case ( 1 )
       !-----------------------------------------
       !     ecmwf scheme
       !-----------------------------------------
       zclear = 1.0
       zcloud = 0.0
       do jk = 1, nlev
          zclear = zclear*(1.0-max(yclfr(jk),zcloud))/(1.0-min(zcloud,1.0-cltres))
          zcloud = yclfr(jk)
          wccro(jk) = 1.0 - zclear
       end do

    case default
       print *, 'unknown switch',IOVLN
       stop 'FATAL BUG IN cf_overhead'

    end select

  END SUBROUTINE CF_OVERHEAD
  !EOC

END MODULE TMM_MF_PRISM