mod_oasis_auxiliary_routines.F90

Go to the documentation of this file.

!> Auxiliary OASIS user interfaces

MODULE mod_oasis_auxiliary_routines
!---------------------------------------------------------------------

    USE mod_oasis_kinds
    USE mod_oasis_data
    USE mod_oasis_parameters
    USE mod_oasis_coupler
    USE mod_oasis_timer
    USE mod_oasis_var
    USE mod_oasis_sys
    USE mod_oasis_io
    USE mod_oasis_mpi
    USE mct_mod

    implicit none
    private

    public oasis_get_localcomm
    public oasis_set_couplcomm
    public oasis_create_couplcomm
    public oasis_get_debug
    public oasis_set_debug
    public oasis_get_intercomm
    public oasis_get_intracomm
    public oasis_get_ncpl
    public oasis_put_inquire
    public oasis_get_freqs

#include "oasis_os.h"

    integer(kind=ip_i4_p)     istatus(mpi_status_size)

!---------------------------------------------------------------------
  CONTAINS
!---------------------------------------------------------------------

!> OASIS user query for the local MPI communicator

  SUBROUTINE oasis_get_localcomm(localcomm,kinfo)

    IMPLICIT NONE

    INTEGER (kind=ip_intwp_p),intent(out)   :: localcomm  !< MPI communicator
    INTEGER (kind=ip_intwp_p),intent(inout),optional :: kinfo  !< return code
!   ---------------------------------------------------------
    character(len=*),parameter :: subname = '(oasis_get_localcomm)'
!   ---------------------------------------------------------

    call oasis_debug_enter(subname)
    if (present(kinfo)) then
       kinfo = oasis_ok
    endif

    ! from prism_data
    localcomm = mpi_comm_local
    IF (oasis_debug >= 2) THEN
        WRITE(nulprt,*) 'localcomm :',localcomm
        CALL oasis_flush(nulprt)
    ENDIF

    call oasis_debug_exit(subname)

  END SUBROUTINE oasis_get_localcomm
!----------------------------------------------------------------------

!> OASIS user call to specify a local communicator

  SUBROUTINE oasis_set_couplcomm(localcomm,kinfo)

    IMPLICIT NONE

    INTEGER (kind=ip_intwp_p),intent(in)   :: localcomm  !< MPI communicator
    INTEGER (kind=ip_intwp_p),intent(inout),optional :: kinfo  !< return code
!   ---------------------------------------------------------
    integer(kind=ip_intwp_p) :: ierr
    character(len=*),parameter :: subname = '(oasis_set_couplcomm)'
!   ---------------------------------------------------------

    call oasis_debug_enter(subname)
    if (present(kinfo)) then
       kinfo = oasis_ok
    endif

    !------------------------
    !--- update mpi_comm_local from component
    !------------------------

    mpi_comm_local = localcomm

    !------------------------
    !--- and now update necessary info
    !------------------------

    mpi_size_local = -1
    mpi_rank_local = -1
    if (mpi_comm_local /= mpi_comm_null) then
       CALL mpi_comm_size(mpi_comm_local,mpi_size_local,ierr)
       CALL mpi_comm_rank(mpi_comm_local,mpi_rank_local,ierr)
       mpi_root_local = 0
    endif

    call oasis_debug_exit(subname)

  END SUBROUTINE oasis_set_couplcomm
!----------------------------------------------------------------------

!> OASIS user call to create a new communicator

  SUBROUTINE oasis_create_couplcomm(icpl,allcomm,cplcomm,kinfo)

    IMPLICIT NONE

    INTEGER (kind=ip_intwp_p),intent(in)   :: icpl  !< coupling process flag 
    INTEGER (kind=ip_intwp_p),intent(in)   :: allcomm  !< input MPI communicator 
    INTEGER (kind=ip_intwp_p),intent(out)  :: cplcomm  !< reduced MPI communicator
    INTEGER (kind=ip_intwp_p),intent(inout),optional :: kinfo  !< return code
!   ---------------------------------------------------------
    integer(kind=ip_intwp_p) :: ierr
    character(len=*),parameter :: subname = '(oasis_create_couplcomm)'
!   ---------------------------------------------------------

    call oasis_debug_enter(subname)
    if (present(kinfo)) then
       kinfo = oasis_ok
    endif

    !------------------------
    !--- generate cplcomm from allcomm and icpl
    !------------------------

    CALL mpi_comm_split(allcomm,icpl,1,cplcomm,ierr)
    IF (ierr /= 0) THEN
       WRITE (nulprt,*) subname,estr,'MPI_Comm_Split ierr = ',ierr
       call oasis_abort(file=__file__,line=__line__)
    ENDIF

    !------------------------
    !--- update mpi_comm_local from component
    !------------------------

    call oasis_set_couplcomm(cplcomm)

    IF (oasis_debug >= 2)  THEN
       WRITE (nulprt,*) 'New local coupling comm =',cplcomm
       CALL oasis_flush(nulprt)
    ENDIF

    call oasis_debug_exit(subname)

  END SUBROUTINE oasis_create_couplcomm
!----------------------------------------------------------------------

!> OASIS user interface to query debug level

  SUBROUTINE oasis_get_debug(debug,kinfo)

    IMPLICIT NONE

    INTEGER (kind=ip_intwp_p),intent(out)   :: debug  !< debug level
    INTEGER (kind=ip_intwp_p),intent(inout),optional :: kinfo  !< return code
!   ---------------------------------------------------------
    character(len=*),parameter :: subname = '(oasis_get_debug)'
!   ---------------------------------------------------------

    call oasis_debug_enter(subname)
    if (present(kinfo)) then
       kinfo = oasis_ok
    endif

    debug = oasis_debug

    call oasis_debug_exit(subname)

  END SUBROUTINE oasis_get_debug
!----------------------------------------------------------------------

!> OASIS user interface to set debug level

  SUBROUTINE oasis_set_debug(debug,kinfo)

    IMPLICIT NONE

    INTEGER (kind=ip_intwp_p),intent(in)   :: debug  !< debug level
    INTEGER (kind=ip_intwp_p),intent(inout),optional :: kinfo  !< return code
!   ---------------------------------------------------------
    character(len=*),parameter :: subname = '(oasis_set_debug)'
!   ---------------------------------------------------------

    call oasis_debug_enter(subname)
    if (present(kinfo)) then
       kinfo = oasis_ok
    endif

    oasis_debug = debug
    if (oasis_debug >= 2) then
       write(nulprt,*) subname,' set OASIS_debug to ',oasis_debug
       CALL oasis_flush(nulprt)
    endif

    call oasis_debug_exit(subname)

  END SUBROUTINE oasis_set_debug
!----------------------------------------------------------------------

!> OASIS user interface to establish an intercomm communicator between the root of two models

  SUBROUTINE oasis_get_intercomm(new_comm, cdnam, kinfo)

    IMPLICIT NONE

    INTEGER (kind=ip_intwp_p),intent(out) :: new_comm  !< out MPI communicator
    CHARACTER(len=*),intent(in) :: cdnam               !< other model name to link with
    INTEGER (kind=ip_intwp_p),intent(out),optional :: kinfo  !< return code

    integer(kind=ip_intwp_p)              :: n, il, ierr, tag
    LOGICAL :: found
!   ---------------------------------------------------------
    character(len=*),parameter :: subname = '(oasis_get_intercomm)'
!   ---------------------------------------------------------

    call oasis_debug_enter(subname)
    if (present(kinfo)) then
       kinfo = oasis_ok
    endif

    found = .false.
    do n = 1,prism_amodels
       if (trim(cdnam) == trim(prism_modnam(n))) then
          if (found) then
             write(nulprt,*) subname,estr,'found same model name twice'
             call oasis_abort(file=__file__,line=__line__)
          endif
          il = n
          found = .true.
       endif
    enddo

    if (.not. found) then
       write(nulprt,*) subname,estr,'input model name not found'
       call oasis_abort(file=__file__,line=__line__)
    endif

    IF (oasis_debug >= 2) THEN
       WRITE(nulprt,*) subname, 'cdnam :',trim(cdnam),' il :',il, &
                       'mpi_root_global(il) :',mpi_root_global(il),&
                       'mpi_comm_local :',mpi_comm_local
       CALL oasis_flush(nulprt)
    ENDIF

    tag=ichar(trim(compnm))+ichar(trim(cdnam))
    CALL mpi_intercomm_create(mpi_comm_local, 0, mpi_comm_global, &
                              mpi_root_global(il), tag, new_comm, ierr)

    call oasis_debug_exit(subname)

  END SUBROUTINE oasis_get_intercomm
!----------------------------------------------------------------------

!> OASIS user interface to establish an intracomm communicator between the root of two models

  SUBROUTINE oasis_get_intracomm(new_comm, cdnam, kinfo)

    IMPLICIT NONE

    INTEGER (kind=ip_intwp_p),intent(out) :: new_comm  !< output MPI communicator
    CHARACTER(len=*),intent(in) :: cdnam               !< other model name
    INTEGER (kind=ip_intwp_p),intent(out),optional :: kinfo  !< return code

    integer(kind=ip_intwp_p)              :: tmp_intercomm
    integer(kind=ip_intwp_p)              :: ierr
!   ---------------------------------------------------------
    character(len=*),parameter :: subname = '(oasis_get_intracomm)'
!   ---------------------------------------------------------

    call oasis_debug_enter(subname)
    if (present(kinfo)) then
       kinfo = oasis_ok
    endif

    call oasis_get_intercomm(tmp_intercomm, cdnam, kinfo)

    CALL mpi_intercomm_merge(tmp_intercomm,.false., new_comm, ierr)

    call oasis_debug_exit(subname)

  END SUBROUTINE oasis_get_intracomm
!----------------------------------------------------------------------

!> OASIS user query for the number of unique couplings associated with a variable

  SUBROUTINE oasis_get_ncpl(varid, ncpl, kinfo)

    IMPLICIT none
    !-------------------------------------
    INTEGER(kind=ip_i4_p) , INTENT(in)  :: varid   !< variable id
    INTEGER(kind=ip_i4_p) , INTENT(out) :: ncpl    !< number of namcouple couplings
    INTEGER(kind=ip_i4_p) , INTENT(out) :: kinfo   !< return code
    !-------------------------------------
    CHARACTER(len=ic_lvar)  :: vname
    CHARACTER(len=*),PARAMETER :: subname = 'oasis_get_ncpl'
    !-------------------------------------

    CALL oasis_debug_enter(subname)

    IF (mpi_comm_local == mpi_comm_null) THEN
       WRITE(nulprt,*) subname,estr,'called on non coupling task'
       call oasis_abort(file=__file__,line=__line__)
    ENDIF

    kinfo = oasis_ok
    vname = prism_var(varid)%name
    
    IF (varid == oasis_var_uncpl) THEN
       WRITE(nulprt,*) subname,estr,'Routine is called for an invalid varid'
       call oasis_abort(file=__file__,line=__line__)
    ENDIF
    
    ncpl  = prism_var(varid)%ncpl
    
    IF (ncpl <= 0) THEN
       IF (oasis_debug >= 2) WRITE(nulprt,*) subname,' Variable not coupled ',&
                              trim(vname)
    ELSE 
       IF (oasis_debug >= 2)  WRITE(nulprt,*) subname,' Variable: ',trim(vname),&
                              ' used in ',ncpl,' couplings' 
    ENDIF

    CALL oasis_debug_exit(subname)
    
  END SUBROUTINE oasis_get_ncpl
!---------------------------------------------------------------------

!> OASIS user query for the coupling periods for a given variable

  SUBROUTINE oasis_get_freqs(varid, mop, ncpl, cpl_freqs, kinfo)

    IMPLICIT none
    !-------------------------------------
    INTEGER(kind=ip_i4_p) , INTENT(in)  :: varid          !< variable id
    INTEGER(kind=ip_i4_p) , INTENT(in)  :: mop            !< OASIS_Out or OASIS_In type
    INTEGER(kind=ip_i4_p) , INTENT(in)  :: ncpl           !< number of namcouple couplings
    INTEGER(kind=ip_i4_p) , INTENT(out) :: cpl_freqs(ncpl)!< coupling period (sec)
    INTEGER(kind=ip_i4_p) , INTENT(out) :: kinfo          !< return code
    !-------------------------------------
    CHARACTER(len=ic_lvar)  :: vname
    INTEGER(kind=ip_i4_p)   :: ncpl_calc, cplid, nc
    CHARACTER(len=*),PARAMETER :: subname = 'oasis_get_freqs'
    !-------------------------------------

    CALL oasis_debug_enter(subname)

    IF (mpi_comm_local == mpi_comm_null) THEN
       WRITE(nulprt,*) subname,estr,'called on non coupling task'
       call oasis_abort(file=__file__,line=__line__)
    ENDIF

    kinfo = oasis_ok
    vname = prism_var(varid)%name
    
    IF (varid == oasis_var_uncpl) THEN
       WRITE(nulprt,*) subname,estr,'Routine is called for an invalid varid'
       call oasis_abort(file=__file__,line=__line__)
    ENDIF
    
    ncpl_calc  = prism_var(varid)%ncpl

    IF (ncpl_calc /= ncpl) THEN
       WRITE(nulprt,*) subname,estr,' Wrong number of couplings for variable: ',trim(vname), &
                       ncpl_calc, ncpl
       call oasis_abort(file=__file__,line=__line__)
    ENDIF
    
    IF (ncpl <= 0) THEN
       IF (oasis_debug >= 2) WRITE(nulprt,*) subname,' variable not coupled ',&
                              trim(vname)
    ENDIF

    DO nc = 1,ncpl
       cplid           = prism_var(varid)%cpl(nc)
       IF (mop == oasis_out) THEN
          cpl_freqs(nc)   = prism_coupler_put(cplid)%dt
       ENDIF
       IF (mop == oasis_in ) THEN
          cpl_freqs(nc)   = prism_coupler_get(cplid)%dt
       ENDIF

       IF (oasis_debug >=2 ) THEN
          WRITE(nulprt,*)  subname,' Coupling frequency of this field ',trim(vname),&
                           ' for coupling ',nc, ' is ',cpl_freqs(nc)
       ENDIF

       IF (cpl_freqs(nc) .le. 0) THEN
          WRITE(nulprt,*) subname,estr,' The coupling frequency is < or equal to 0'
          call oasis_abort(file=__file__,line=__line__)
       ENDIF
    ENDDO

    CALL oasis_debug_exit(subname)

  END SUBROUTINE oasis_get_freqs
!---------------------------------------------------------------------

!> OASIS user query to indicate put return code expected at a specified time for a given variable

  SUBROUTINE oasis_put_inquire(varid,msec,kinfo)

    IMPLICIT none
    !-------------------------------------
    integer(kind=ip_i4_p) , intent(in)  :: varid   !< variable id
    integer(kind=ip_i4_p) , intent(in)  :: msec    !< model time in seconds
    integer(kind=ip_i4_p) , intent(out) :: kinfo   !< return code
    !-------------------------------------
    character(len=ic_lvar)     :: vname
    INTEGER(kind=ip_i4_p)      :: ncpl, nc, cplid
    INTEGER(kind=ip_i4_p)      :: lag, mseclag, trans, dt, getput, maxtime
    LOGICAL                    :: time_now, sndrcv, output
    character(len=*),parameter :: subname = 'oasis_put_inquire'
    !-------------------------------------

    CALL oasis_debug_enter(subname)

    IF (mpi_comm_local == mpi_comm_null) THEN
       WRITE(nulprt,*) subname,estr,'called on non coupling task'
       call oasis_abort(file=__file__,line=__line__)
    ENDIF

    kinfo = oasis_ok
    vname = prism_var(varid)%name
    
    IF (varid == oasis_var_uncpl) THEN
       WRITE(nulprt,*) subname,estr, &
          'Routine oasis_put is called for a variable not in namcouple: it will not be sent'
       call oasis_abort(file=__file__,line=__line__)
    ENDIF
    
    ncpl  = prism_var(varid)%ncpl
    
    IF (ncpl <= 0) THEN
       IF (oasis_debug >= 2) WRITE(nulprt,*) subname,' variable not coupled ',&
                              trim(vname)
    ENDIF

    DO nc = 1,ncpl

       cplid   = prism_var(varid)%cpl(nc)
       dt      = prism_coupler_put(cplid)%dt
       lag     = prism_coupler_put(cplid)%lag
       getput  = prism_coupler_put(cplid)%getput
       sndrcv  = prism_coupler_put(cplid)%sndrcv
       maxtime = prism_coupler_put(cplid)%maxtime
       output  = prism_coupler_put(cplid)%output
       trans   = prism_coupler_put(cplid)%trans

       !------------------------------------------------
       ! check that lag is reasonable
       !------------------------------------------------

       IF (abs(lag) > dt) THEN
          WRITE(nulprt,*) subname,estr,' ERROR lag gt dt for cplid',cplid
          call oasis_abort(file=__file__,line=__line__)
       ENDIF

       !------------------------------------------------
       ! check that field is OASIS_PUT
       !------------------------------------------------

       IF (getput == oasis3_get) THEN
          WRITE(nulprt,*) subname,estr,'routine can only be called for OASIS_PUT variable'
          call oasis_abort(file=__file__,line=__line__)
       ENDIF

       CALL oasis_debug_note(subname//' set mseclag')
       IF (getput == oasis3_put) THEN
          mseclag = msec + lag
       ENDIF

       !------------------------------------------------
       ! check that model hasn't gone past maxtime
       !------------------------------------------------

       if (msec >= maxtime) then
          write(nulprt,*) subname,' at ',msec,mseclag,'  ERROR: ',trim(vname)
          write(nulprt,*) subname,estr,'model time beyond namcouple maxtime',&
                          msec,maxtime
          call oasis_abort(file=__file__,line=__line__)
       endif

       time_now = .false.
       IF (mod(mseclag,dt) == 0) time_now = .true.

       !-------------------------------------------------------------------
       ! Test what is the current status of the field if time_now = .TRUE.
       !-------------------------------------------------------------------

       IF (time_now .EQV. .true.) THEN

          IF (oasis_debug >= 2) THEN
             WRITE(nulprt,*) subname,' Coupling time for : ',trim(vname)
             WRITE(nulprt,*) subname,'  Coupling time for var for nc : ',&
                 trim(mct_avect_exportrlist2c(prism_coupler_put(cplid)%avect1)),nc
             WRITE(nulprt,*) subname,' dt,msec,mseclag = ',dt,msec,mseclag
             CALL oasis_flush(nulprt)
          ENDIF

          IF ( (trans == ip_average) .OR. (trans == ip_accumul) .OR. (trans == ip_max) &
                                     .OR. (trans == ip_min) ) THEN
             IF (kinfo == oasis_ok) kinfo = oasis_loctrans
             IF (oasis_debug >= 2) THEN
                WRITE(nulprt,*) subname,' status at ',msec,mseclag,' WTRN '
                CALL oasis_flush(nulprt)
             ENDIF
          ENDIF

          !-------------------------------------------------------------------
          ! past namcouple runtime (maxtime) no communication
          ! do restart if time+lag = maxtime, this assumes coupling
          ! period and lag and maxtime are all nicely consistent
          !-------------------------------------------------------------------
          IF (mseclag >= maxtime) THEN
             IF (getput == oasis3_put .AND. lag > 0 .AND. mseclag == maxtime) THEN
                kinfo = oasis_torest
                IF (oasis_debug >= 2) THEN
                   WRITE(nulprt,*) subname,' status at ',msec,mseclag,' WRST '
                   CALL oasis_flush(nulprt)
                ENDIF
             ENDIF
          ENDIF
          
          !------------------------------------------------
          ! communication
          !------------------------------------------------
          IF (sndrcv) THEN
             IF (getput == oasis3_put) THEN
                kinfo = oasis_sent
                IF (oasis_debug >= 2) THEN
                   WRITE(nulprt,*) subname,' status at ',msec,mseclag,' will be SENT '
                   CALL oasis_flush(nulprt)
                ENDIF
             ENDIF
          ENDIF

          !------------------------------------------------
          ! save debug file if EXPOUT or OUTPUT
          !------------------------------------------------
          IF (output) THEN
             IF (kinfo == oasis_sent) THEN
                 kinfo = oasis_sentout
             ELSEIF (kinfo == oasis_torest) THEN
                 kinfo = oasis_torestout
             ELSE
                 kinfo = oasis_output
             ENDIF
             IF (oasis_debug >= 2) THEN
                WRITE(nulprt,*) subname,' status at ',msec,mseclag,' will be WRIT '
                CALL oasis_flush(nulprt)
             ENDIF
          ENDIF

          !------------------------------------------------
          ! sav non-instant loctrans operations for future restart
          !   at the end of the run only
          !------------------------------------------------

          IF (mseclag + dt >= maxtime .AND. &
             getput == oasis3_put .and. trans /= ip_instant) then
             IF (oasis_debug >= 2) THEN
                WRITE(nulprt,*) subname,' at ',msec,mseclag,' will be WTRN: '
                CALL oasis_flush(nulprt)
             ENDIF
          ENDIF
       ELSE
          IF (oasis_debug >=2) THEN
              WRITE(nulprt,*) 'Nothing to do'
          ENDIF
       ENDIF ! time_now

       IF (oasis_debug >= 2) THEN
          WRITE(nulprt,*) subname,' kinfo: ',kinfo
          CALL oasis_flush(nulprt)
       ENDIF
    ENDDO  ! nc

    CALL oasis_debug_exit(subname)

    END SUBROUTINE oasis_put_inquire

!---------------------------------------------------------------------------------
  END MODULE mod_oasis_auxiliary_routines