source: palm/trunk/SOURCE/pmc_general.f90 @ 1765

MODULE pmc_general

!--------------------------------------------------------------------------------!
! This file is part of PALM.
!
! PALM is free software: you can redistribute it and/or modify it under the terms
! of the GNU General Public License as published by the Free Software Foundation,
! either version 3 of the License, or (at your option) any later version.
!
! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License along with
! PALM. If not, see <http://www.gnu.org/licenses/>.
!
! Copyright 1997-2015 Leibniz Universitaet Hannover
!--------------------------------------------------------------------------------!
!
! Current revisions:
! ------------------
!
!
! Former revisions:
! -----------------
! $Id: pmc_general.f90 1765 2016-02-28 13:30:40Z raasch $
!
! 1764 2016-02-28 12:45:19Z raasch
! cpp-statement added (nesting can only be used in parallel mode),
! all kinds given in PALM style
!
! 1762 2016-02-25 12:31:13Z hellstea
! Initial revision by K. Ketelsen
!
! Description:
! ------------
!
! Structure definition and utilities of Palm Model Coupler
!------------------------------------------------------------------------------!

#if defined( __parallel )
   use, intrinsic :: iso_c_binding

   USE kinds

#if defined( __lc )
    USE MPI
#else
    INCLUDE "mpif.h"
#endif

   IMPLICIT none
   PRIVATE
   SAVE

! return status
   INTEGER,parameter,PUBLIC              :: PMC_STATUS_OK    = 0
   INTEGER,parameter,PUBLIC              :: PMC_STATUS_ERROR = -1
   INTEGER,parameter,PUBLIC              :: PMC_DA_NAME_ERR  = 10

   INTEGER,parameter,PUBLIC              :: PMC_MAX_MODELL   = 64
!  TO_DO: the next variable doesn't seem to be used.  Remove?
   INTEGER,parameter,PUBLIC              :: PMC_MPI_REAL     = MPI_DOUBLE_PRECISION
   INTEGER,parameter,PUBLIC              :: DA_Desclen       = 8
   INTEGER,parameter,PUBLIC              :: DA_Namelen       = 16

   TYPE, PUBLIC :: xy_ind                                          ! Pair of indices in horizontal plane
      INTEGER                       ::  i
      INTEGER                       ::  j
   END TYPE

   TYPE, PUBLIC :: ArrayDef
      INTEGER                       :: coupleIndex
      INTEGER                       :: NrDims                      ! Number of Dimensions
      INTEGER,DIMENSION(4)          :: A_dim                       ! Size of dimensions
      INTEGER                       :: dim_order                   ! Order of Dimensions: 2 = 2D array, 33 = 3D array
      TYPE (c_ptr)                  :: data                        ! Pointer of data in server space
      INTEGER(idp)                  :: BufIndex                    ! index in Send Buffer
      INTEGER                       :: BufSize                     ! size in Send Buffer
      TYPE (c_ptr)                  :: SendBuf                     ! Pointer of Data in Send buffer
      CHARACTER(len=8)              :: Name                        ! Name of Array

      Type(ArrayDef),POINTER        :: next
   END TYPE ArrayDef

   TYPE (ArrayDef), PUBLIC, POINTER :: next;

   TYPE, PUBLIC :: PeDef
      INTEGER(idp)                        :: NrEle                 ! Number of Elemets
      TYPE (xy_ind), POINTER,DIMENSION(:) :: locInd                ! xy index local array for remote PE
      TYPE( ArrayDef), POINTER            :: Arrays                ! Pointer to Data Array List (Type ArrayDef)
      TYPE( ArrayDef), POINTER            :: ArrayStart            ! Pointer to Star of the List
   END TYPE PeDef

   TYPE, PUBLIC :: ClientDef
      INTEGER(idp)                  :: TotalBufferSize
      INTEGER                       :: model_comm                  ! Communicator of this model
      INTEGER                       :: inter_comm                  ! Inter communicator model and client
      INTEGER                       :: intra_comm                  ! Intra communicator model and client
      INTEGER                       :: model_rank                  ! Rank of this model
      INTEGER                       :: model_npes                  ! Number of PEs this model
      INTEGER                       :: inter_npes                  ! Number of PEs client model
      INTEGER                       :: intra_rank                  ! rank within intra_comm
      INTEGER                       :: BufWin                      ! MPI RMA windows
      TYPE (PeDef), DIMENSION(:), POINTER      :: PEs              ! List of all Client PEs
   END TYPE ClientDef

   TYPE, PUBLIC    :: DA_NameDef                                   ! Data Array Name Definition
      INTEGER                       :: couple_index                ! Unique Number of Array
      CHARACTER(len=DA_Desclen)     :: ServerDesc                  ! Server array description
      CHARACTER(len=DA_Namelen)     :: NameOnServer                ! Name of array within Server
      CHARACTER(len=DA_Desclen)     :: ClientDesc                  ! Client array description
      CHARACTER(len=DA_Namelen)     :: NameOnClient                ! Name of array within Client
    END TYPE DA_NameDef

    INTERFACE PMC_G_SetName
       MODULE procedure PMC_G_SetName
    end INTERFACE PMC_G_SetName

    INTERFACE PMC_G_GetName
       MODULE procedure PMC_G_GetName
    end INTERFACE PMC_G_GetName

    INTERFACE PMC_sort
       MODULE procedure sort_2d_i
    end INTERFACE PMC_sort

    PUBLIC PMC_G_SetName, PMC_G_GetName, PMC_sort


 CONTAINS
    SUBROUTINE PMC_G_SetName (myClient, couple_index, aName)
       IMPLICIT none

       TYPE(ClientDef),INTENT(INOUT)           :: myClient
       INTEGER,INTENT(IN)                      :: couple_index
       CHARACTER(LEN=*)                        :: aName

       INTEGER                                 :: i
       TYPE(ArrayDef),POINTER                  :: ar
       TYPE(PeDef),POINTER                     :: aPE

       do i=1,myClient%inter_npes
          aPE => myClient%PEs(i)
          ar  => aPE%Arrays
          if(.not. associated (ar) )  then
             ar => DA_List_append (ar, couple_index)
             aPE%ArrayStart => ar
         else
             ar => DA_List_append (ar, couple_index)
           endif
          Ar%Name    = trim(aName) // " "
          myClient%PEs(i)%Arrays => ar
       end do

       return
    end SUBROUTINE PMC_G_SetName

    SUBROUTINE PMC_G_GetName (myClient, couple_index, aName, aLast,Client_PeIndex)
       IMPLICIT none

       TYPE(ClientDef),INTENT(INOUT)           :: myClient
       INTEGER,INTENT(OUT)                     :: couple_index
       CHARACTER(LEN=*),INTENT(OUT)            :: aName
       logical,INTENT(OUT)                     :: aLast
       INTEGER,INTENT(IN),optional             :: Client_PeIndex

       INTEGER                                 :: i,istart,istop
       TYPE(PeDef),POINTER                     :: aPE
       TYPE(ArrayDef),POINTER                  :: ar
       logical,save                            :: first=.true.

       aLast = .false.

       if(present(Client_PeIndex))  then       !Loop over all Client PEs or just one selected via Client_PeIndex
          istart = Client_PeIndex
          istop  = Client_PeIndex
       else
          istart = 1
          istop  = myClient%inter_npes
       end if

       do i=istart,istop
          aPE => myClient%PEs(i)
          ar  => aPE%Arrays
          if(first)  then
             ar => aPE%ArrayStart
          else
             ar => aPE%Arrays
             ar => DA_List_next (ar)
             if(.not. associated (ar) )  then
                aLast = .true.
                first = .true.                                  !Reset linked list to begin
                aPE%Arrays => ar
              end if
          endif
          aPE%Arrays => ar
       end do
       if(aLast) then
          return
       end if

       couple_index = ar%coupleIndex
       aName        = ar%Name
       aLast        = .false.

       first = .false.


       return
    END SUBROUTINE PMC_G_GetName

    SUBROUTINE sort_2d_i (array,sort_ind)
       IMPLICIT none
       INTEGER,DIMENSION(:,:),INTENT(INOUT)         :: array
       INTEGER,INTENT(IN)                           :: sort_ind

       !-- local Variables
       INTEGER      :: i,j,n
       INTEGER,DIMENSION(size(array,1))             :: tmp

       n = size(array,2)
       do j=1,n-1
          do i=j+1,n
             if(array(sort_ind,i) < array(sort_ind,j) )  then
                tmp = array(:,i)
                array(:,i) = array(:,j)
                array(:,j) = tmp
             end if
          end do
       end do

       return
    END  SUBROUTINE sort_2d_i

!   Private section
!   linked List routines for Data Array handling

    FUNCTION DA_List_append   (node, couple_index)
       TYPE(ArrayDef),POINTER      :: DA_List_append
       TYPE(ArrayDef),POINTER      :: node
       INTEGER,INTENT(IN)          :: couple_index

!--    local variables
       TYPE(ArrayDef),POINTER      :: ar

       if(.not. associated (node))   then
          ALLOCATE(ar)
          ar%coupleIndex = couple_index
          NULLIFY(ar%next)
          DA_List_append => ar
       else
          ALLOCATE(node%next)
          node%next%coupleIndex = couple_index
          NULLIFY(node%next%next)
          DA_List_append => node%next
       end if

       return
    END FUNCTION DA_List_append

    FUNCTION DA_List_next   (node)
       TYPE(ArrayDef),POINTER      :: DA_List_next
       TYPE(ArrayDef),POINTER      :: node

       DA_List_next => node%next

       return
    END FUNCTION DA_List_next

#endif
end MODULE pmc_general