Index: palm/trunk/SOURCE/pmc_server.f90
===================================================================
--- palm/trunk/SOURCE/pmc_server.f90	(revision 1767)
+++ palm/trunk/SOURCE/pmc_server.f90	(revision 1779)
@@ -20,5 +20,7 @@
 ! Current revisions:
 ! ------------------
-!
+! kind=dp replaced by wp,
+! error messages removed or changed to PALM style, dim_order removed
+! array management changed from linked list to sequential loop
 !
 ! Former revisions:
@@ -52,5 +54,5 @@
    USE  kinds
    USE  PMC_general,               ONLY: ClientDef, PMC_MAX_MODELL,PMC_sort, DA_NameDef, DA_Desclen, DA_Namelen,       &
-                                         PMC_G_SetName, PMC_G_GetName, PeDef, ArrayDef
+                                         PMC_G_SetName, PeDef, ArrayDef, PMC_MAX_ARRAY
    USE  PMC_handle_communicator,   ONLY: m_model_comm,m_model_rank,m_model_npes, m_to_client_comm,                     &
                                          PMC_Server_for_Client, m_world_rank
@@ -70,11 +72,7 @@
    TYPE(ClientIndexDef),DIMENSION(PMC_MAX_MODELL)     :: indClients
 
+   INTEGER                                            :: next_array_in_list = 0
+
    PUBLIC PMC_Server_for_Client
-
-!-- TO_DO: what is the meaning of this? Could variables declared in this module
-!--        also have single precision?
-!   INTEGER, PARAMETER :: dp = wp
-
-   ! INTERFACE section
 
    INTERFACE PMC_ServerInit
@@ -85,4 +83,8 @@
         MODULE procedure PMC_S_Set_2D_index_list
     END INTERFACE PMC_S_Set_2D_index_list
+
+    INTERFACE PMC_S_clear_next_array_list
+        MODULE procedure PMC_S_clear_next_array_list
+    END INTERFACE PMC_S_clear_next_array_list
 
     INTERFACE PMC_S_GetNextArray
@@ -115,4 +117,5 @@
     PUBLIC PMC_ServerInit, PMC_S_Set_2D_index_list, PMC_S_GetNextArray, PMC_S_Set_DataArray
     PUBLIC PMC_S_setInd_and_AllocMem, PMC_S_FillBuffer, PMC_S_GetData_from_Buffer, PMC_S_Set_Active_data_array
+    PUBLIC PMC_S_clear_next_array_list
 
 CONTAINS
@@ -145,7 +148,8 @@
 
          ALLOCATE (Clients(ClientId)%PEs(Clients(ClientId)%inter_npes))
-
-         do j=1,Clients(ClientId)%inter_npes                                ! Loop over all client PEs
-           NULLIFY(Clients(ClientId)%PEs(j)%Arrays)
+!
+!--      Allocate for all client PEs an array of TYPE ArrayDef to store information of transfer array
+         do j=1,Clients(ClientId)%inter_npes
+           Allocate(Clients(ClientId)%PEs(j)%array_list(PMC_MAX_ARRAY))
          end do
 
@@ -219,36 +223,48 @@
     END SUBROUTINE PMC_S_Set_2D_index_list
 
-    logical function PMC_S_GetNextArray (ClientId, myName,Client_PeIndex)
+    SUBROUTINE PMC_S_clear_next_array_list
+       IMPLICIT none
+
+       next_array_in_list = 0
+
+       return
+    END SUBROUTINE PMC_S_clear_next_array_list
+
+!   List handling is still required to get minimal interaction with pmc_interface
+    logical function PMC_S_GetNextArray (ClientId, myName)
+       INTEGER(iwp),INTENT(IN)                    :: ClientId
+       CHARACTER(len=*),INTENT(OUT)               :: myName
+
+!--    local variables
+       TYPE(PeDef),POINTER          :: aPE
+       TYPE(ArrayDef),POINTER       :: ar
+
+       next_array_in_list = next_array_in_list+1
+
+!--    Array Names are the same on all client PE, so take first PE to get the name
+       aPE => Clients(ClientId)%PEs(1)
+
+       if(next_array_in_list > aPE%Nr_arrays) then
+          PMC_S_GetNextArray = .false.              ! all arrays done
+          return
+       end if
+
+       ar  => aPE%array_list(next_array_in_list)
+       myName = ar%name
+
+       PMC_S_GetNextArray =  .true.                 ! Return true if legal array
+       return
+    END function PMC_S_GetNextArray
+
+    SUBROUTINE PMC_S_Set_DataArray_2d (ClientId, array, array_2 )
+
+        IMPLICIT none
+
         INTEGER,INTENT(IN)                         :: ClientId
-        CHARACTER(len=*),INTENT(OUT)               :: myName
-
-        !-- local variables
-        INTEGER                      :: MyCoupleIndex
-        logical                      :: MyLast
-        CHARACTER(len=DA_Namelen)    :: loName
-        INTEGER,INTENT(IN),optional  :: Client_PeIndex
-
-        loName = ' '
-
-        CALL PMC_G_GetName (clients(ClientId), MyCoupleIndex, loName, MyLast, Client_PeIndex)
-
-        myName    = loName
-
-        PMC_S_GetNextArray = .NOT. MyLast                   ! Return true if valid array
-
-        return
-    END function PMC_S_GetNextArray
-
-    SUBROUTINE PMC_S_Set_DataArray_2d (ClientId, array, array_2 )
-        IMPLICIT none
-        INTEGER,INTENT(IN)                         :: ClientId
-!--   TO_DO: has array always to be of dp-kind, or can wp used here
-!--          this effects all respective declarations in this file
-        REAL(kind=dp),INTENT(IN),DIMENSION(:,:)           :: array
-        REAL(kind=dp),INTENT(IN),DIMENSION(:,:),OPTIONAL  :: array_2
-        !-- local variables
+        REAL(wp), INTENT(IN), DIMENSION(:,:)           ::  array
+        REAL(wp), INTENT(IN), DIMENSION(:,:), OPTIONAL ::  array_2
+
         INTEGER                           :: NrDims
         INTEGER,DIMENSION (4)             :: dims
-        INTEGER                           :: dim_order
         TYPE(c_ptr)                       :: array_adr
         TYPE(c_ptr)                       :: second_adr
@@ -259,13 +275,11 @@
         dims(1)   = size(array,1)
         dims(2)   = size(array,2)
-        dim_order = 2
-
         array_adr = c_loc(array)
 
         IF ( PRESENT( array_2 ) )  THEN
            second_adr = c_loc(array_2)
-           CALL PMC_S_SetArray (ClientId, NrDims, dims, dim_order, array_adr, second_adr = second_adr)
+           CALL PMC_S_SetArray (ClientId, NrDims, dims, array_adr, second_adr = second_adr)
         ELSE
-           CALL PMC_S_SetArray (ClientId, NrDims, dims, dim_order, array_adr)
+           CALL PMC_S_SetArray (ClientId, NrDims, dims, array_adr)
         ENDIF
 
@@ -274,14 +288,15 @@
 
     SUBROUTINE PMC_S_Set_DataArray_3d (ClientId, array, nz_cl, nz, array_2 )
+
         IMPLICIT none
+
         INTEGER,INTENT(IN)                         :: ClientId
-        REAL(kind=dp),INTENT(IN),DIMENSION(:,:,:)  :: array
-        REAL(kind=dp),INTENT(IN),DIMENSION(:,:,:),OPTIONAL  :: array_2
+        REAL(wp), INTENT(IN), DIMENSION(:,:,:)           ::  array
+        REAL(wp), INTENT(IN), DIMENSION(:,:,:), OPTIONAL ::  array_2
         INTEGER,INTENT(IN)                         :: nz_cl
         INTEGER,INTENT(IN)                         :: nz
-        !-- local variables
+
         INTEGER                           :: NrDims
         INTEGER,DIMENSION (4)             :: dims
-        INTEGER                           :: dim_order
         TYPE(c_ptr)                       :: array_adr
         TYPE(c_ptr)                       :: second_adr
@@ -294,5 +309,4 @@
         dims(2)   = size(array,2)
         dims(3)   = size(array,3)
-        dim_order = 33
         dims(4)   = nz_cl+dims(1)-nz                        ! works for first dimension 1:nz and 0:nz+1
 
@@ -304,7 +318,7 @@
         IF ( PRESENT( array_2 ) )  THEN
           second_adr = c_loc(array_2)
-          CALL PMC_S_SetArray (ClientId, NrDims, dims, dim_order, array_adr, second_adr = second_adr)
+          CALL PMC_S_SetArray (ClientId, NrDims, dims, array_adr, second_adr = second_adr)
         ELSE
-           CALL PMC_S_SetArray (ClientId, NrDims, dims, dim_order, array_adr)
+           CALL PMC_S_SetArray (ClientId, NrDims, dims, array_adr)
         ENDIF
 
@@ -313,8 +327,13 @@
 
    SUBROUTINE PMC_S_setInd_and_AllocMem (ClientId)
+
+      USE control_parameters,                                                  &
+          ONLY:  message_string
+
       IMPLICIT none
+
       INTEGER,INTENT(IN)                      :: ClientId
 
-      INTEGER                                 :: i, istat, ierr
+      INTEGER                                 :: i, istat, ierr, j
       INTEGER                                 :: arlen, myIndex, tag
       INTEGER                                 :: rCount                    ! count MPI requests
@@ -337,9 +356,9 @@
          aPE => Clients(ClientId)%PEs(i)
          tag = 200
-         do while (PMC_S_GetNextArray ( ClientId, myName,i))
-            ar  => aPE%Arrays
-            if(ar%dim_order == 2) then
+         do j=1,aPE%Nr_arrays
+            ar  => aPE%array_list(j)
+            if(ar%NrDims == 2) then
                arlen     = aPE%NrEle;                             ! 2D
-            else if(ar%dim_order == 33) then
+            else if(ar%NrDims == 3) then
                arlen     = aPE%NrEle * ar%A_dim(4);               ! PALM 3D
             else
@@ -382,11 +401,11 @@
       do i=1,Clients(ClientId)%inter_npes
          aPE => Clients(ClientId)%PEs(i)
-         do while (PMC_S_GetNextArray ( ClientId, myName,i))
-            ar  => aPE%Arrays
+         do j=1,aPE%Nr_arrays
+            ar  => aPE%array_list(j)
 !--         TO_DO:  Adressrechnung ueberlegen?
             ar%SendBuf = c_loc(base_array(ar%BufIndex))                         !kk Adressrechnung ueberlegen
             if(ar%BufIndex+ar%BufSize > bufsize) then
 !--            TO_DO: can this error really happen, and what can be the reason?
-               write(0,'(a,i4,4i7,1x,a)') 'Buffer too small ',i,ar%BufIndex,ar%BufSize,ar%BufIndex+ar%BufSize,bufsize,trim(myName)
+               write(0,'(a,i4,4i7,1x,a)') 'Buffer too small ',i,ar%BufIndex,ar%BufSize,ar%BufIndex+ar%BufSize,bufsize,trim(ar%name)
                CALL MPI_Abort (MPI_COMM_WORLD, istat, ierr)
             end if
@@ -399,18 +418,17 @@
    SUBROUTINE PMC_S_FillBuffer (ClientId, WaitTime)
       IMPLICIT none
-      INTEGER,INTENT(IN)                      :: ClientId
-      REAL(kind=dp),INTENT(OUT),optional      :: WaitTime
-
-      !-- local variables
-      INTEGER                                 :: ip,ij,istat,ierr
-      INTEGER                                 :: myIndex
-      REAL(kind=dp)                           :: t1,t2
-      TYPE(PeDef),POINTER                     :: aPE
-      TYPE(ArrayDef),POINTER                  :: ar
-      CHARACTER(len=DA_Namelen)               :: myName
-      INTEGER,DIMENSION(1)                    :: buf_shape
-      REAL(kind=wp),POINTER,DIMENSION(:)      :: buf
-      REAL(kind=wp),POINTER,DIMENSION(:,:)    :: data_2d
-      REAL(kind=wp),POINTER,DIMENSION(:,:,:)  :: data_3d
+      INTEGER,INTENT(IN)                  ::  ClientId
+      REAL(wp), INTENT(OUT), OPTIONAL     ::  WaitTime
+
+      INTEGER                             ::  ip,ij,istat,ierr,j
+      INTEGER                             ::  myIndex
+      REAL(wp)                            ::  t1,t2
+      TYPE(PeDef),POINTER                 ::  aPE
+      TYPE(ArrayDef),POINTER              ::  ar
+      CHARACTER(len=DA_Namelen)           ::  myName
+      INTEGER,DIMENSION(1)                ::  buf_shape
+      REAL(wp), POINTER, DIMENSION(:)     ::  buf
+      REAL(wp), POINTER, DIMENSION(:,:)   ::  data_2d
+      REAL(wp), POINTER, DIMENSION(:,:,:) ::  data_3d
 
       t1 = PMC_Time()
@@ -421,8 +439,8 @@
       do ip=1,Clients(ClientId)%inter_npes
          aPE => Clients(ClientId)%PEs(ip)
-         do while (PMC_S_GetNextArray ( ClientId, myName,ip))
-            ar  => aPE%Arrays
+         do j=1,aPE%Nr_arrays
+            ar  => aPE%array_list(j)
             myIndex=1
-            if(ar%dim_order == 2) then
+            if(ar%NrDims == 2) then
                buf_shape(1) = aPE%NrEle
                CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
@@ -432,5 +450,5 @@
                   myIndex = myIndex+1
                end do
-            else if(ar%dim_order == 33) then
+            else if(ar%NrDims == 3) then
                buf_shape(1) = aPE%NrEle*ar%A_dim(4)
                CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
@@ -440,14 +458,9 @@
                   myIndex = myIndex+ar%A_dim(4)
                end do
-            else
-!--            TO_DO: can this error really happen, and what can be the reason?
-               write(0,*) "Illegal Order of Dimension ",ar%dim_order
-               CALL MPI_Abort (MPI_COMM_WORLD, istat, ierr);
-
             end if
           end do
       end do
 
-      CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)              ! buffer is full
+      CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)    ! buffer is full
 
       return
@@ -455,19 +468,21 @@
 
    SUBROUTINE PMC_S_GetData_from_Buffer (ClientId, WaitTime)
+
       IMPLICIT none
-      INTEGER,INTENT(IN)                      :: ClientId
-      REAL(kind=dp),INTENT(OUT),optional      :: WaitTime
+
+      INTEGER,INTENT(IN)                  ::  ClientId
+      REAL(wp), INTENT(OUT), OPTIONAL     ::  WaitTime
 
       !-- local variables
-      INTEGER                                 :: ip,ij,istat,ierr
-      INTEGER                                 :: myIndex
-      REAL(kind=dp)                           :: t1,t2
-      TYPE(PeDef),POINTER                     :: aPE
-      TYPE(ArrayDef),POINTER                  :: ar
-      CHARACTER(len=DA_Namelen)               :: myName
-      INTEGER,DIMENSION(1)                    :: buf_shape
-      REAL(kind=wp),POINTER,DIMENSION(:)      :: buf
-      REAL(kind=wp),POINTER,DIMENSION(:,:)    :: data_2d
-      REAL(kind=wp),POINTER,DIMENSION(:,:,:)  :: data_3d
+      INTEGER                             ::  ip,ij,istat,ierr,j
+      INTEGER                             ::  myIndex
+      REAL(wp)                            ::  t1,t2
+      TYPE(PeDef),POINTER                 ::  aPE
+      TYPE(ArrayDef),POINTER              ::  ar
+      CHARACTER(len=DA_Namelen)           ::  myName
+      INTEGER,DIMENSION(1)                ::  buf_shape
+      REAL(wp), POINTER, DIMENSION(:)     ::  buf
+      REAL(wp), POINTER, DIMENSION(:,:)   ::  data_2d
+      REAL(wp), POINTER, DIMENSION(:,:,:) ::  data_3d
 
       t1 = PMC_Time()
@@ -478,8 +493,8 @@
       do ip=1,Clients(ClientId)%inter_npes
          aPE => Clients(ClientId)%PEs(ip)
-         do while (PMC_S_GetNextArray ( ClientId, myName,ip))
-            ar  => aPE%Arrays
+         do j=1,aPE%Nr_arrays
+            ar  => aPE%array_list(j)
             myIndex=1
-            if(ar%dim_order == 2) then
+            if(ar%NrDims == 2) then
                buf_shape(1) = aPE%NrEle
                CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
@@ -489,5 +504,5 @@
                   myIndex = myIndex+1
                end do
-            else if(ar%dim_order == 33) then
+            else if(ar%NrDims == 3) then
                buf_shape(1) = aPE%NrEle*ar%A_dim(4)
                CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
@@ -497,9 +512,4 @@
                   myIndex = myIndex+ar%A_dim(4)
                end do
-            else
-!--            TO_DO: can this error really happen, and what can be the reason?
-               write(0,*) "Illegal Order of Dimension ",ar%dim_order
-               CALL MPI_Abort (MPI_COMM_WORLD, istat, ierr);
-
             end if
           end do
@@ -535,5 +545,5 @@
    END SUBROUTINE Get_DA_names_from_client
 
-   SUBROUTINE PMC_S_SetArray (ClientId, NrDims, dims, dim_order, array_adr, second_adr)
+   SUBROUTINE PMC_S_SetArray (ClientId, NrDims, dims, array_adr, second_adr)
       IMPLICIT none
 
@@ -541,5 +551,4 @@
       INTEGER,INTENT(IN)                      :: NrDims
       INTEGER,INTENT(IN),DIMENSION(:)         :: dims
-      INTEGER,INTENT(IN)                      :: dim_order
       TYPE(c_ptr),INTENT(IN)                  :: array_adr
       TYPE(c_ptr),INTENT(IN),OPTIONAL         :: second_adr
@@ -554,8 +563,7 @@
        do i=1,Clients(ClientId)%inter_npes
           aPE => Clients(ClientId)%PEs(i)
-          ar  => aPE%Arrays
+          ar  => aPE%array_list(next_array_in_list)
           ar%NrDims    = NrDims
           ar%A_dim     = dims
-          ar%dim_order = dim_order
           ar%data      = array_adr
           if(present(second_adr)) then
@@ -579,5 +587,5 @@
 
 !--   local variables
-      INTEGER                                 :: i, ip
+      INTEGER                                 :: i, ip, j
       TYPE(PeDef),POINTER                     :: aPE
       TYPE(ArrayDef),POINTER                  :: ar
@@ -586,6 +594,6 @@
       do ip=1,Clients(ClientId)%inter_npes
          aPE => Clients(ClientId)%PEs(ip)
-         do while (PMC_S_GetNextArray ( ClientId, myName,ip))
-            ar  => aPE%Arrays
+         do j=1,aPE%Nr_arrays
+            ar  => aPE%array_list(j)
             if(iactive == 1 .OR. iactive == 2)   then
                ar%data = ar%po_data(iactive)
