Ignore:
Timestamp:
May 4, 2016 3:27:53 PM (5 years ago)
Author:
raasch
Message:

re-formatting of remaining pmc routines

File:
1 edited

Legend:

Unmodified
Added
Removed
  • palm/trunk/SOURCE/pmc_mpi_wrapper_mod.f90

    r1851 r1900  
    1 MODULE pmc_mpi_wrapper
     1 MODULE pmc_mpi_wrapper
    22
    33!--------------------------------------------------------------------------------!
     
    2020! Current revisions:
    2121! ------------------
    22 !
     22! re-formatted to match PALM style
    2323!
    2424! Former revisions:
     
    5050
    5151#if defined( __parallel )
    52    use, intrinsic :: iso_c_binding
     52    USE, INTRINSIC ::  ISO_C_BINDING
    5353
    5454#if defined( __mpifh )
     
    5757    USE MPI
    5858#endif
    59    USE  kinds
    60    USE  PMC_handle_communicator, ONLY: m_to_server_comm, m_to_client_comm, m_model_comm, m_model_rank
    61    IMPLICIT none
    62    PRIVATE
    63    SAVE
    64 
    65    INTERFACE PMC_Send_to_Server
    66       MODULE PROCEDURE PMC_Send_to_Server_INTEGER
    67       MODULE PROCEDURE PMC_Send_to_Server_INTEGER_2
    68       MODULE PROCEDURE PMC_Send_to_Server_real_r1
    69       MODULE PROCEDURE PMC_Send_to_Server_real_r2
    70       MODULE PROCEDURE PMC_Send_to_Server_real_r3
    71    END INTERFACE PMC_Send_to_Server
    72 
    73    INTERFACE PMC_Recv_from_Server
    74       MODULE PROCEDURE PMC_Recv_from_Server_INTEGER
    75       MODULE PROCEDURE PMC_Recv_from_Server_real_r1
    76       MODULE PROCEDURE PMC_Recv_from_Server_real_r2
    77       MODULE PROCEDURE PMC_Recv_from_Server_real_r3
    78    END INTERFACE PMC_Recv_from_Server
    79 
    80    INTERFACE PMC_Send_to_Client
    81       MODULE PROCEDURE PMC_Send_to_Client_INTEGER
    82       MODULE PROCEDURE PMC_Send_to_Client_real_r1
    83       MODULE PROCEDURE PMC_Send_to_Client_real_r2
    84       MODULE PROCEDURE PMC_Send_to_Client_real_r3
    85    END INTERFACE PMC_Send_to_Client
    86 
    87    INTERFACE PMC_Recv_from_Client
    88       MODULE PROCEDURE PMC_Recv_from_Client_INTEGER
    89       MODULE PROCEDURE PMC_Recv_from_Client_INTEGER_2
    90       MODULE PROCEDURE PMC_Recv_from_Client_real_r1
    91       MODULE PROCEDURE PMC_Recv_from_Client_real_r2
    92       MODULE PROCEDURE PMC_Recv_from_Client_real_r3
    93    END INTERFACE PMC_Recv_from_Client
    94 
    95    INTERFACE PMC_Bcast
    96       MODULE PROCEDURE PMC_Bcast_INTEGER
    97       MODULE PROCEDURE PMC_Bcast_character
    98    END INTERFACE PMC_Bcast
    99 
    100    INTERFACE PMC_Inter_Bcast
    101       MODULE PROCEDURE PMC_Inter_Bcast_INTEGER_1
    102    END INTERFACE PMC_Inter_Bcast
    103 
    104    INTERFACE PMC_Alloc_mem
    105       MODULE PROCEDURE PMC_Alloc_mem_INTEGER_1
    106       MODULE PROCEDURE PMC_Alloc_mem_Real_1
    107    END INTERFACE PMC_Alloc_mem
    108 
    109    INTERFACE PMC_TIME
    110       MODULE PROCEDURE PMC_TIME
    111    END INTERFACE PMC_TIME
    112 
    113    PUBLIC PMC_Send_to_Server, PMC_Recv_from_Server
    114    PUBLIC PMC_Send_to_Client, PMC_Recv_from_Client
    115    PUBLIC PMC_Bcast, PMC_Inter_Bcast, PMC_Alloc_mem
    116    PUBLIC PMC_TIME
    117 
    118 CONTAINS
    119 
    120    SUBROUTINE  PMC_Send_to_Server_INTEGER (buf, n, Server_rank, tag, ierr)
    121       IMPLICIT     none
    122       INTEGER, DIMENSION(:), INTENT(IN)         :: buf
    123       INTEGER, INTENT(IN)                       :: n
    124       INTEGER, INTENT(IN)                       :: Server_rank
    125       INTEGER, INTENT(IN)                       :: tag
    126       INTEGER, INTENT(OUT)                      :: ierr
    127    
    128       ierr = 0
    129       CALL MPI_Send (buf, n, MPI_INTEGER, Server_rank, tag, m_to_server_comm, ierr)
    130    
    131       return
    132    END SUBROUTINE  PMC_Send_to_Server_INTEGER
    133 
    134    SUBROUTINE  PMC_Recv_from_Server_INTEGER (buf, n, Server_rank, tag, ierr)
    135       IMPLICIT     none
    136       INTEGER, DIMENSION(:), INTENT(OUT)        :: buf
    137       INTEGER, INTENT(IN)                       :: n
    138       INTEGER, INTENT(IN)                       :: Server_rank
    139       INTEGER, INTENT(IN)                       :: tag
    140       INTEGER, INTENT(OUT)                      :: ierr
    141 
    142       ierr = 0
    143       CALL MPI_Recv (buf, n, MPI_INTEGER, Server_rank, tag, m_to_server_comm, &
    144          MPI_STATUS_IGNORE, ierr)
    145 
    146       return
    147    END SUBROUTINE  PMC_Recv_from_Server_INTEGER
    148 
    149    SUBROUTINE  PMC_Send_to_Server_INTEGER_2 (buf, n, Server_rank, tag, ierr)
    150       IMPLICIT     none
    151       INTEGER, DIMENSION(:,:), INTENT(IN)       :: buf
    152       INTEGER, INTENT(IN)                       :: n
    153       INTEGER, INTENT(IN)                       :: Server_rank
    154       INTEGER, INTENT(IN)                       :: tag
    155       INTEGER, INTENT(OUT)                      :: ierr
    156 
    157       ierr = 0
    158       CALL MPI_Send (buf, n, MPI_INTEGER, Server_rank, tag, m_to_server_comm, ierr)
    159 
    160       return
    161    END SUBROUTINE  PMC_Send_to_Server_INTEGER_2
    162 
    163    SUBROUTINE  PMC_Send_to_Server_real_r1 (buf, n, Server_rank, tag, ierr)
    164 
    165       IMPLICIT     none
    166 
    167       REAL(wp), DIMENSION(:), INTENT(IN) ::  buf
    168       INTEGER, INTENT(IN)                ::  n
    169       INTEGER, INTENT(IN)                ::  Server_rank
    170       INTEGER, INTENT(IN)                ::  tag
    171       INTEGER, INTENT(OUT)               ::  ierr
    172 
    173       ierr = 0
    174       CALL MPI_Send (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, ierr)
    175 
    176       return
    177    END SUBROUTINE  PMC_Send_to_Server_real_r1
    178 
    179    SUBROUTINE  PMC_Recv_from_Server_real_r1 (buf, n, Server_rank, tag, ierr)
    180 
    181       IMPLICIT     none
    182 
    183       REAL(wp), DIMENSION(:), INTENT(OUT) ::  buf
    184       INTEGER, INTENT(IN)                 ::  n
    185       INTEGER, INTENT(IN)                 ::  Server_rank
    186       INTEGER, INTENT(IN)                 ::  tag
    187       INTEGER, INTENT(OUT)                ::  ierr
    188 
    189       ierr = 0
    190       CALL MPI_Recv (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm,     &
    191                      MPI_STATUS_IGNORE, ierr)
    192 
    193       return
    194    END SUBROUTINE  PMC_Recv_from_Server_real_r1
    195 
    196    SUBROUTINE  PMC_Send_to_Server_real_r2 (buf, n, Server_rank, tag, ierr)
    197 
    198       IMPLICIT     none
    199 
    200       REAL(wp), DIMENSION(:,:), INTENT(IN) ::  buf
    201       INTEGER, INTENT(IN)                  ::  n
    202       INTEGER, INTENT(IN)                  ::  Server_rank
    203       INTEGER, INTENT(IN)                  ::  tag
    204       INTEGER, INTENT(OUT)                 ::  ierr
    205 
    206       ierr = 0
    207       CALL MPI_Send (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, ierr)
    208 
    209       return
    210    END SUBROUTINE  PMC_Send_to_Server_real_r2
    211 
    212    SUBROUTINE  PMC_Recv_from_Server_real_r2 (buf, n, Server_rank, tag, ierr)
    213 
    214       IMPLICIT     none
    215 
    216       REAL(wp), DIMENSION(:,:), INTENT(OUT) ::  buf
    217       INTEGER, INTENT(IN)                   ::  n
    218       INTEGER, INTENT(IN)                   ::  Server_rank
    219       INTEGER, INTENT(IN)                   ::  tag
    220       INTEGER, INTENT(OUT)                  ::  ierr
    221 
    222       ierr = 0
    223       CALL MPI_Recv (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, &
    224          MPI_STATUS_IGNORE, ierr)
    225 
    226       return
    227    END SUBROUTINE  PMC_Recv_from_Server_real_r2
    228 
    229    SUBROUTINE  PMC_Send_to_Server_real_r3 (buf, n, Server_rank, tag, ierr)
    230 
    231       IMPLICIT     none
    232 
    233       REAL(wp), DIMENSION(:,:,:), INTENT(IN) ::  buf
    234       INTEGER, INTENT(IN)                    ::  n
    235       INTEGER, INTENT(IN)                    ::  Server_rank
    236       INTEGER, INTENT(IN)                    ::  tag
    237       INTEGER, INTENT(OUT)                   ::  ierr
    238 
    239       ierr = 0
    240       CALL MPI_Send (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, ierr)
    241 
    242       return
    243    END SUBROUTINE  PMC_Send_to_Server_real_r3
    244 
    245    SUBROUTINE  PMC_Recv_from_Server_real_r3 (buf, n, Server_rank, tag, ierr)
    246 
    247       IMPLICIT     none
    248 
    249       REAL(wp), DIMENSION(:,:,:), INTENT(OUT) ::  buf
    250       INTEGER, INTENT(IN)                     ::  n
    251       INTEGER, INTENT(IN)                     ::  Server_rank
    252       INTEGER, INTENT(IN)                     ::  tag
    253       INTEGER, INTENT(OUT)                    ::  ierr
    254 
    255       ierr = 0
    256       CALL MPI_Recv (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, &
    257          MPI_STATUS_IGNORE, ierr)
    258 
    259       return
    260    END SUBROUTINE  PMC_Recv_from_Server_real_r3
    261 
    262 
    263    SUBROUTINE  PMC_Send_to_Client_INTEGER (Client_id, buf, n, Client_rank, tag, ierr)
    264       IMPLICIT     none
    265       INTEGER, INTENT(IN)                       :: Client_id
    266       INTEGER, DIMENSION(:), INTENT(IN)         :: buf
    267       INTEGER, INTENT(IN)                       :: n
    268       INTEGER, INTENT(IN)                       :: Client_rank
    269       INTEGER, INTENT(IN)                       :: tag
    270       INTEGER, INTENT(OUT)                      :: ierr
    271 
    272       ierr = 0
    273       CALL MPI_Send (buf, n, MPI_INTEGER, Client_rank, tag, m_to_client_comm(Client_id), ierr)
    274 
    275       return
    276    END SUBROUTINE  PMC_Send_to_Client_INTEGER
    277 
    278    SUBROUTINE  PMC_Recv_from_Client_INTEGER (Client_id, buf, n, Client_rank, tag, ierr)
    279       IMPLICIT     none
    280       INTEGER, INTENT(IN)                       :: Client_id
    281       INTEGER, DIMENSION(:), INTENT(INOUT)      :: buf
    282       INTEGER, INTENT(IN)                       :: n
    283       INTEGER, INTENT(IN)                       :: Client_rank
    284       INTEGER, INTENT(IN)                       :: tag
    285       INTEGER, INTENT(OUT)                      :: ierr
    286 
    287       ierr = 0
    288       CALL MPI_Recv (buf, n, MPI_INTEGER, Client_rank, tag, m_to_client_comm(Client_id), &
    289          MPI_STATUS_IGNORE, ierr)
    290 
    291       return
    292    END SUBROUTINE  PMC_Recv_from_Client_INTEGER
    293 
    294    SUBROUTINE  PMC_Recv_from_Client_INTEGER_2 (Client_id, buf, n, Client_rank, tag, ierr)
    295       IMPLICIT     none
    296       INTEGER, INTENT(IN)                       :: Client_id
    297       INTEGER, DIMENSION(:,:), INTENT(OUT)      :: buf
    298       INTEGER, INTENT(IN)                       :: n
    299       INTEGER, INTENT(IN)                       :: Client_rank
    300       INTEGER, INTENT(IN)                       :: tag
    301       INTEGER, INTENT(OUT)                      :: ierr
    302 
    303       ierr = 0
    304       CALL MPI_Recv (buf, n, MPI_INTEGER, Client_rank, tag, m_to_client_comm(Client_id), &
    305          MPI_STATUS_IGNORE, ierr)
    306 
    307       return
    308    END SUBROUTINE  PMC_Recv_from_Client_INTEGER_2
    309 
    310    SUBROUTINE  PMC_Send_to_Client_real_r1 (Client_id, buf, n, Client_rank, tag, ierr)
    311 
    312       IMPLICIT     none
    313 
    314       INTEGER, INTENT(IN)                ::  Client_id
    315       REAL(wp), DIMENSION(:), INTENT(IN) ::  buf
    316       INTEGER, INTENT(IN)                ::  n
    317       INTEGER, INTENT(IN)                ::  Client_rank
    318       INTEGER, INTENT(IN)                ::  tag
    319       INTEGER, INTENT(OUT)               ::  ierr
    320 
    321       ierr = 0
    322       CALL MPI_Send (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
    323          ierr)
    324 
    325       return
    326    END SUBROUTINE  PMC_Send_to_Client_real_r1
    327 
    328    SUBROUTINE  PMC_Recv_from_Client_real_r1 (Client_id, buf, n, Client_rank, tag, ierr)
    329 
    330       IMPLICIT     none
    331 
    332       INTEGER, INTENT(IN)                   ::  Client_id
    333       REAL(wp), DIMENSION(:), INTENT(INOUT) ::  buf
    334       INTEGER, INTENT(IN)                   ::  n
    335       INTEGER, INTENT(IN)                   ::  Client_rank
    336       INTEGER, INTENT(IN)                   ::  tag
    337       INTEGER, INTENT(OUT)                  ::  ierr
    338 
    339       ierr = 0
    340       CALL MPI_Recv (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
    341          MPI_STATUS_IGNORE, ierr)
    342 
    343       return
    344    END SUBROUTINE  PMC_Recv_from_Client_real_r1
    345 
    346    SUBROUTINE  PMC_Send_to_Client_real_r2 (Client_id, buf, n, Client_rank, tag, ierr)
    347 
    348       IMPLICIT     none
    349 
    350       INTEGER, INTENT(IN)                  ::  Client_id
    351       REAL(wp), DIMENSION(:,:), INTENT(IN) ::  buf
    352       INTEGER, INTENT(IN)                  ::  n
    353       INTEGER, INTENT(IN)                  ::  Client_rank
    354       INTEGER, INTENT(IN)                  ::  tag
    355       INTEGER, INTENT(OUT)                 ::  ierr
    356 
    357       ierr = 0
    358       CALL MPI_Send (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
    359          ierr)
    360 
    361       return
    362    END SUBROUTINE  PMC_Send_to_Client_real_r2
    363 
    364    SUBROUTINE  PMC_Recv_from_Client_real_r2 (Client_id, buf, n, Client_rank, tag, ierr)
    365 
    366       IMPLICIT     none
    367 
    368       INTEGER, INTENT(IN)                   ::  Client_id
    369       REAL(wp), DIMENSION(:,:), INTENT(OUT) ::  buf
    370       INTEGER, INTENT(IN)                   ::  n
    371       INTEGER, INTENT(IN)                   ::  Client_rank
    372       INTEGER, INTENT(IN)                   ::  tag
    373       INTEGER, INTENT(OUT)                  ::  ierr
    374 
    375       ierr = 0
    376       CALL MPI_Recv (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
    377          MPI_STATUS_IGNORE, ierr)
    378 
    379       return
    380    END SUBROUTINE  PMC_Recv_from_Client_real_r2
    381 
    382    SUBROUTINE  PMC_Send_to_Client_real_r3 (Client_id, buf, n, Client_rank, tag, ierr)
    383 
    384       IMPLICIT     none
    385 
    386       INTEGER, INTENT(IN)                    ::  Client_id
    387       REAL(wp), DIMENSION(:,:,:), INTENT(IN) ::  buf
    388       INTEGER, INTENT(IN)                    ::  n
    389       INTEGER, INTENT(IN)                    ::  Client_rank
    390       INTEGER, INTENT(IN)                    ::  tag
    391       INTEGER, INTENT(OUT)                   ::  ierr
    392 
    393       ierr = 0
    394       CALL MPI_Send (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
    395          ierr)
    396 
    397       return
    398    END SUBROUTINE  PMC_Send_to_Client_real_r3
    399 
    400    SUBROUTINE  PMC_Recv_from_Client_real_r3 (Client_id, buf, n, Client_rank, tag, ierr)
    401 
    402       IMPLICIT     none
    403 
    404       INTEGER, INTENT(IN)                     ::  Client_id
    405       REAL(wp), DIMENSION(:,:,:), INTENT(OUT) ::  buf
    406       INTEGER, INTENT(IN)                     :: n
    407       INTEGER, INTENT(IN)                     :: Client_rank
    408       INTEGER, INTENT(IN)                     :: tag
    409       INTEGER, INTENT(OUT)                    :: ierr
    410 
    411       ierr = 0
    412       CALL MPI_Recv (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
    413          MPI_STATUS_IGNORE, ierr)
    414 
    415       return
    416    END SUBROUTINE  PMC_Recv_from_Client_real_r3
    417 
    418    SUBROUTINE  PMC_Bcast_INTEGER (buf, root_pe, comm, ierr)
    419       IMPLICIT     none
    420       INTEGER, INTENT(INOUT)                      :: buf
    421       INTEGER, INTENT(IN)                         :: root_pe
    422       INTEGER, INTENT(IN),optional                :: comm
    423       INTEGER, INTENT(OUT),optional               :: ierr
    424       !-- local variables
    425       INTEGER                                     :: myComm
    426       INTEGER                                     :: myErr
    427 
    428       if(present (comm))  then
    429          myComm = comm
    430       else
    431          myComm = m_model_comm
    432       end if
    433 
    434       CALL MPI_Bcast (buf, 1, MPI_INTEGER, root_pe, myComm, myErr)
    435 
    436       if(present (ierr))  then
    437          ierr = myErr
    438       end if
    439 
    440       return
    441    END SUBROUTINE  PMC_Bcast_INTEGER
    442 
    443    SUBROUTINE  PMC_Bcast_character (buf, root_pe, comm, ierr)
    444       IMPLICIT     none
    445       character(len=*), INTENT(INOUT)             :: buf
    446       INTEGER, INTENT(IN)                         :: root_pe
    447       INTEGER, INTENT(IN),optional                :: comm
    448       INTEGER, INTENT(OUT),optional               :: ierr
    449       !-- local variables
    450       INTEGER                                     :: myComm
    451       INTEGER                                     :: myErr
    452 
    453       if(present (comm))  then
    454          myComm = comm
    455       else
    456          myComm = m_model_comm
    457       end if
    458 
    459       CALL MPI_Bcast (buf, len(buf), MPI_Character, root_pe, myComm, myErr)
    460 
    461       if(present (ierr))  then
    462          ierr = myErr
    463       end if
    464 
    465       return
    466    END SUBROUTINE  PMC_Bcast_character
    467 
    468    SUBROUTINE  PMC_Inter_Bcast_INTEGER_1 (buf, Client_id, ierr)
    469       IMPLICIT     none
    470       INTEGER, INTENT(INOUT),DIMENSION(:)         :: buf
    471       INTEGER, INTENT(IN),optional                :: Client_id
    472       INTEGER, INTENT(OUT),optional               :: ierr
    473       !-- local variables
    474       INTEGER                                     :: myComm
    475       INTEGER                                     :: myErr
    476       INTEGER                                     :: root_pe
    477 
    478       !   PE 0 Server Broadcast to all Client PE's
    479 
    480       if(present (Client_id))  then
    481          myComm  = m_to_client_comm(Client_id)
    482          if(m_model_rank == 0)  then
    483             root_pe = MPI_ROOT
    484          else
    485             root_pe = MPI_PROC_NULL
    486          end if
    487       else
    488          myComm  = m_to_server_comm
    489          root_pe = 0
    490       end if
    491 
    492       CALL MPI_Bcast (buf, size(buf), MPI_INTEGER, root_pe, myComm, myErr)
    493 
    494       if(present (ierr))  then
    495          ierr = myErr
    496       end if
    497 
    498       return
    499    END SUBROUTINE  PMC_Inter_Bcast_INTEGER_1
    500 
    501 !  Allocate  Memory with MPI_Alloc_mem using intermediate C-pointer
    502 
    503    SUBROUTINE  PMC_Alloc_mem_INTEGER_1 (iarray, idim1)
    504       IMPLICIT     none
    505       INTEGER,DIMENSION(:),POINTER,INTENT(INOUT) :: iarray
    506       INTEGER,INTENT(IN)                         :: idim1
    507 
    508       Type(c_ptr)                             :: p_myInd
    509       INTEGER,DIMENSION(1)                    :: aShape
    510       INTEGER(KIND=MPI_ADDRESS_KIND)          :: WinSize
    511       INTEGER                                 :: ierr
    512 
    513       WinSize = idim1*c_sizeof(ierr)                          ! Length of INTEGER
    514 
    515       CALL MPI_Alloc_mem  (WinSize , MPI_INFO_NULL, p_myInd, ierr);
    516       aShape(1) = idim1
    517       CALL c_f_pointer(p_myInd,iarray,aShape)
    518 
    519       return
    520    END SUBROUTINE  PMC_Alloc_mem_INTEGER_1
    521 
    522    SUBROUTINE  PMC_Alloc_mem_Real_1 (array, idim1, base_ptr)
    523       IMPLICIT     none
    524       REAL(kind=wp),DIMENSION(:),POINTER,INTENT(INOUT) :: array
    525       INTEGER(idp),INTENT(IN)                          :: idim1
    526       Type(c_ptr),INTENT(OUT),optional                 :: base_ptr
    527 
    528 
    529       Type(c_ptr)                             :: p_myInd
    530       INTEGER,DIMENSION(1)                    :: aShape
    531       INTEGER(KIND=MPI_ADDRESS_KIND)          :: WinSize
    532       INTEGER                                 :: ierr
    533 
    534       WinSize = idim1*wp                          ! Length of INTEGER
    535 
    536       CALL MPI_Alloc_mem  (WinSize , MPI_INFO_NULL, p_myInd, ierr);
    537       aShape(1) = idim1
    538       CALL c_f_pointer(p_myInd,array,aShape)
    539 
    540       if(present(base_ptr))   then
    541          base_ptr = p_myInd
    542       end if
    543 
    544       return
    545    END SUBROUTINE  PMC_Alloc_mem_Real_1
    546 
    547    FUNCTION PMC_TIME ()
    548       REAL(kind=wp)          :: PMC_TIME
    549 
    550       PMC_TIME = MPI_Wtime ()
    551 
    552       return
    553 
    554     END FUNCTION PMC_TIME
     59
     60    USE kinds
     61    USE pmc_handle_communicator,                                               &
     62        ONLY: m_model_comm, m_model_rank, m_to_server_comm, m_to_client_comm
     63
     64    IMPLICIT NONE
     65
     66    PRIVATE
     67    SAVE
     68
     69    INTERFACE pmc_send_to_server
     70       MODULE PROCEDURE pmc_send_to_server_integer
     71       MODULE PROCEDURE pmc_send_to_server_integer_2
     72       MODULE PROCEDURE pmc_send_to_server_real_r1
     73       MODULE PROCEDURE pmc_send_to_server_real_r2
     74       MODULE PROCEDURE pmc_send_to_server_real_r3
     75    END INTERFACE pmc_send_to_server
     76
     77    INTERFACE pmc_recv_from_server
     78       MODULE PROCEDURE pmc_recv_from_server_integer
     79       MODULE PROCEDURE pmc_recv_from_server_real_r1
     80       MODULE PROCEDURE pmc_recv_from_server_real_r2
     81       MODULE PROCEDURE pmc_recv_from_server_real_r3
     82    END INTERFACE pmc_recv_from_server
     83
     84    INTERFACE pmc_send_to_client
     85       MODULE PROCEDURE pmc_send_to_client_integer
     86       MODULE PROCEDURE pmc_send_to_client_real_r1
     87       MODULE PROCEDURE pmc_send_to_client_real_r2
     88       MODULE PROCEDURE pmc_send_to_client_real_r3
     89    END INTERFACE pmc_send_to_client
     90
     91    INTERFACE pmc_recv_from_client
     92       MODULE PROCEDURE pmc_recv_from_client_integer
     93       MODULE PROCEDURE pmc_recv_from_client_integer_2
     94       MODULE PROCEDURE pmc_recv_from_client_real_r1
     95       MODULE PROCEDURE pmc_recv_from_client_real_r2
     96       MODULE PROCEDURE pmc_recv_from_client_real_r3
     97    END INTERFACE pmc_recv_from_client
     98
     99    INTERFACE pmc_bcast
     100       MODULE PROCEDURE pmc_bcast_integer
     101       MODULE PROCEDURE pmc_bcast_character
     102    END INTERFACE pmc_bcast
     103
     104    INTERFACE pmc_inter_bcast
     105       MODULE PROCEDURE pmc_inter_bcast_integer_1
     106    END INTERFACE pmc_inter_bcast
     107
     108    INTERFACE pmc_alloc_mem
     109       MODULE PROCEDURE pmc_alloc_mem_integer_1
     110       MODULE PROCEDURE pmc_alloc_mem_Real_1
     111    END INTERFACE pmc_alloc_mem
     112
     113    INTERFACE pmc_time
     114       MODULE PROCEDURE pmc_time
     115    END INTERFACE pmc_time
     116
     117    PUBLIC pmc_alloc_mem, pmc_bcast, pmc_inter_bcast, pmc_recv_from_client,    &
     118           pmc_recv_from_server, pmc_send_to_client, pmc_send_to_server,       &
     119           pmc_time
     120
     121 CONTAINS
     122
     123
     124 SUBROUTINE pmc_send_to_server_integer( buf, n, server_rank, tag, ierr )
     125
     126    IMPLICIT NONE
     127
     128    INTEGER, DIMENSION(:), INTENT(IN) ::  buf          !<
     129    INTEGER, INTENT(IN)               ::  n            !<
     130    INTEGER, INTENT(IN)               ::  server_rank  !<
     131    INTEGER, INTENT(IN)               ::  tag          !<
     132    INTEGER, INTENT(OUT)              ::  ierr         !<
     133
     134    ierr = 0
     135    CALL MPI_SEND( buf, n, MPI_INTEGER, server_rank, tag, m_to_server_comm,    &
     136                   ierr)
     137
     138 END SUBROUTINE pmc_send_to_server_integer
     139
     140
     141
     142 SUBROUTINE pmc_recv_from_server_integer( buf, n, server_rank, tag, ierr )
     143
     144    IMPLICIT NONE
     145
     146    INTEGER, DIMENSION(:), INTENT(OUT) ::  buf          !<
     147    INTEGER, INTENT(IN)                ::  n            !<
     148    INTEGER, INTENT(IN)                ::  server_rank  !<
     149    INTEGER, INTENT(IN)                ::  tag          !<
     150    INTEGER, INTENT(OUT)               ::  ierr         !<
     151
     152    ierr = 0
     153    CALL MPI_RECV( buf, n, MPI_INTEGER, server_rank, tag, m_to_server_comm,    &
     154                   MPI_STATUS_IGNORE, ierr )
     155
     156 END SUBROUTINE pmc_recv_from_server_integer
     157
     158
     159
     160 SUBROUTINE pmc_send_to_server_integer_2( buf, n, server_rank, tag, ierr )
     161
     162    IMPLICIT NONE
     163
     164    INTEGER, DIMENSION(:,:), INTENT(IN) :: buf          !<
     165    INTEGER, INTENT(IN)                 :: n            !<
     166    INTEGER, INTENT(IN)                 :: server_rank  !<
     167    INTEGER, INTENT(IN)                 :: tag          !<
     168    INTEGER, INTENT(OUT)                :: ierr         !<
     169
     170    ierr = 0
     171    CALL MPI_SEND( buf, n, MPI_INTEGER, server_rank, tag, m_to_server_comm,    &
     172                   ierr )
     173
     174 END SUBROUTINE pmc_send_to_server_integer_2
     175
     176
     177
     178 SUBROUTINE pmc_send_to_server_real_r1( buf, n, server_rank, tag, ierr )
     179
     180    IMPLICIT NONE
     181
     182    REAL(wp), DIMENSION(:), INTENT(IN) ::  buf          !<
     183    INTEGER, INTENT(IN)                ::  n            !<
     184    INTEGER, INTENT(IN)                ::  server_rank  !<
     185    INTEGER, INTENT(IN)                ::  tag          !<
     186    INTEGER, INTENT(OUT)               ::  ierr         !<
     187
     188    ierr = 0
     189    CALL MPI_SEND( buf, n, MPI_REAL, server_rank, tag, m_to_server_comm, ierr )
     190
     191 END SUBROUTINE pmc_send_to_server_real_r1
     192
     193
     194
     195 SUBROUTINE pmc_recv_from_server_real_r1( buf, n, server_rank, tag, ierr )
     196
     197    IMPLICIT NONE
     198
     199    REAL(wp), DIMENSION(:), INTENT(OUT) ::  buf          !<
     200    INTEGER, INTENT(IN)                 ::  n            !<
     201    INTEGER, INTENT(IN)                 ::  server_rank  !<
     202    INTEGER, INTENT(IN)                 ::  tag          !<
     203    INTEGER, INTENT(OUT)                ::  ierr         !<
     204
     205    ierr = 0
     206    CALL MPI_RECV( buf, n, MPI_REAL, server_rank, tag, m_to_server_comm,       &
     207                   MPI_STATUS_IGNORE, ierr )
     208
     209 END SUBROUTINE pmc_recv_from_server_real_r1
     210
     211
     212
     213 SUBROUTINE pmc_send_to_server_real_r2( buf, n, server_rank, tag, ierr )
     214
     215    IMPLICIT NONE
     216
     217    REAL(wp), DIMENSION(:,:), INTENT(IN) ::  buf          !<
     218    INTEGER, INTENT(IN)                  ::  n            !<
     219    INTEGER, INTENT(IN)                  ::  server_rank  !<
     220    INTEGER, INTENT(IN)                  ::  tag          !<
     221    INTEGER, INTENT(OUT)                 ::  ierr         !<
     222
     223    ierr = 0
     224    CALL MPI_SEND( buf, n, MPI_REAL, server_rank, tag, m_to_server_comm, ierr )
     225
     226 END SUBROUTINE pmc_send_to_server_real_r2
     227
     228
     229 SUBROUTINE pmc_recv_from_server_real_r2( buf, n, server_rank, tag, ierr )
     230
     231    IMPLICIT NONE
     232
     233    REAL(wp), DIMENSION(:,:), INTENT(OUT) ::  buf          !<
     234    INTEGER, INTENT(IN)                   ::  n            !<
     235    INTEGER, INTENT(IN)                   ::  server_rank  !<
     236    INTEGER, INTENT(IN)                   ::  tag          !<
     237    INTEGER, INTENT(OUT)                  ::  ierr         !<
     238
     239    ierr = 0
     240    CALL MPI_RECV( buf, n, MPI_REAL, server_rank, tag, m_to_server_comm,       &
     241                   MPI_STATUS_IGNORE, ierr )
     242
     243 END SUBROUTINE pmc_recv_from_server_real_r2
     244
     245
     246
     247 SUBROUTINE pmc_send_to_server_real_r3( buf, n, server_rank, tag, ierr )
     248
     249    IMPLICIT NONE
     250
     251    REAL(wp), DIMENSION(:,:,:), INTENT(IN) ::  buf          !<
     252    INTEGER, INTENT(IN)                    ::  n            !<
     253    INTEGER, INTENT(IN)                    ::  server_rank  !<
     254    INTEGER, INTENT(IN)                    ::  tag          !<
     255    INTEGER, INTENT(OUT)                   ::  ierr         !<
     256
     257    ierr = 0
     258    CALL MPI_SEND( buf, n, MPI_REAL, server_rank, tag, m_to_server_comm, ierr )
     259
     260 END SUBROUTINE pmc_send_to_server_real_r3
     261
     262
     263
     264 SUBROUTINE pmc_recv_from_server_real_r3( buf, n, server_rank, tag, ierr )
     265
     266    IMPLICIT NONE
     267
     268    REAL(wp), DIMENSION(:,:,:), INTENT(OUT) ::  buf          !<
     269    INTEGER, INTENT(IN)                     ::  n            !<
     270    INTEGER, INTENT(IN)                     ::  server_rank  !<
     271    INTEGER, INTENT(IN)                     ::  tag          !<
     272    INTEGER, INTENT(OUT)                    ::  ierr         !<
     273
     274    ierr = 0
     275    CALL MPI_RECV( buf, n, MPI_REAL, server_rank, tag, m_to_server_comm,       &
     276                   MPI_STATUS_IGNORE, ierr )
     277
     278 END SUBROUTINE pmc_recv_from_server_real_r3
     279
     280
     281
     282 SUBROUTINE pmc_send_to_client_integer( client_id, buf, n, client_rank, tag,   &
     283                                        ierr )
     284
     285    IMPLICIT NONE
     286
     287    INTEGER, INTENT(IN)               ::  client_id    !<
     288    INTEGER, DIMENSION(:), INTENT(IN) ::  buf          !<
     289    INTEGER, INTENT(IN)               ::  n            !<
     290    INTEGER, INTENT(IN)               ::  client_rank  !<
     291    INTEGER, INTENT(IN)               ::  tag          !<
     292    INTEGER, INTENT(OUT)              ::  ierr         !<
     293
     294    ierr = 0
     295    CALL MPI_SEND( buf, n, MPI_INTEGER, client_rank, tag,                      &
     296                   m_to_client_comm(client_id), ierr )
     297
     298 END SUBROUTINE pmc_send_to_client_integer
     299
     300
     301
     302 SUBROUTINE pmc_recv_from_client_integer( client_id, buf, n, client_rank, tag, &
     303                                          ierr )
     304
     305    IMPLICIT NONE
     306
     307    INTEGER, INTENT(IN)                  ::  client_id    !<
     308    INTEGER, DIMENSION(:), INTENT(INOUT) ::  buf          !<
     309    INTEGER, INTENT(IN)                  ::  n            !<
     310    INTEGER, INTENT(IN)                  ::  client_rank  !<
     311    INTEGER, INTENT(IN)                  ::  tag          !<
     312    INTEGER, INTENT(OUT)                 ::  ierr         !<
     313
     314    ierr = 0
     315    CALL MPI_RECV( buf, n, MPI_INTEGER, client_rank, tag,                      &
     316                   m_to_client_comm(client_id), MPI_STATUS_IGNORE, ierr )
     317
     318 END SUBROUTINE pmc_recv_from_client_integer
     319
     320
     321
     322 SUBROUTINE pmc_recv_from_client_integer_2( client_id, buf, n, client_rank,    &
     323                                            tag, ierr )
     324
     325    IMPLICIT NONE
     326
     327    INTEGER, INTENT(IN)                  ::  client_id    !<
     328    INTEGER, DIMENSION(:,:), INTENT(OUT) ::  buf          !<
     329    INTEGER, INTENT(IN)                  ::  n            !<
     330    INTEGER, INTENT(IN)                  ::  client_rank  !<
     331    INTEGER, INTENT(IN)                  ::  tag          !<
     332    INTEGER, INTENT(OUT)                 ::  ierr         !<
     333
     334    ierr = 0
     335    CALL MPI_RECV( buf, n, MPI_INTEGER, client_rank, tag,                      &
     336                   m_to_client_comm(client_id), MPI_STATUS_IGNORE, ierr )
     337
     338 END SUBROUTINE pmc_recv_from_client_integer_2
     339
     340
     341
     342 SUBROUTINE pmc_send_to_client_real_r1( client_id, buf, n, client_rank, tag,   &
     343                                        ierr )
     344
     345    IMPLICIT NONE
     346
     347    INTEGER, INTENT(IN)                ::  client_id    !<
     348    REAL(wp), DIMENSION(:), INTENT(IN) ::  buf          !<
     349    INTEGER, INTENT(IN)                ::  n            !<
     350    INTEGER, INTENT(IN)                ::  client_rank  !<
     351    INTEGER, INTENT(IN)                ::  tag          !<
     352    INTEGER, INTENT(OUT)               ::  ierr         !<
     353
     354    ierr = 0
     355    CALL MPI_SEND( buf, n, MPI_REAL, client_rank, tag,                         &
     356                   m_to_client_comm(client_id), ierr )
     357
     358 END SUBROUTINE pmc_send_to_client_real_r1
     359
     360
     361
     362 SUBROUTINE pmc_recv_from_client_real_r1( client_id, buf, n, client_rank, tag, &
     363                                          ierr )
     364
     365    IMPLICIT NONE
     366
     367    INTEGER, INTENT(IN)                   ::  client_id    !<
     368    REAL(wp), DIMENSION(:), INTENT(INOUT) ::  buf          !<
     369    INTEGER, INTENT(IN)                   ::  n            !<
     370    INTEGER, INTENT(IN)                   ::  client_rank  !<
     371    INTEGER, INTENT(IN)                   ::  tag          !<
     372    INTEGER, INTENT(OUT)                  ::  ierr         !<
     373
     374    ierr = 0
     375    CALL MPI_RECV( buf, n, MPI_REAL, client_rank, tag,                         &
     376                   m_to_client_comm(client_id), MPI_STATUS_IGNORE, ierr )
     377
     378 END SUBROUTINE pmc_recv_from_client_real_r1
     379
     380
     381
     382 SUBROUTINE pmc_send_to_client_real_r2( client_id, buf, n, client_rank, tag,   &
     383                                        ierr )
     384
     385    IMPLICIT NONE
     386
     387    INTEGER, INTENT(IN)                  ::  client_id    !<
     388    REAL(wp), DIMENSION(:,:), INTENT(IN) ::  buf          !<
     389    INTEGER, INTENT(IN)                  ::  n            !<
     390    INTEGER, INTENT(IN)                  ::  client_rank  !<
     391    INTEGER, INTENT(IN)                  ::  tag          !<
     392    INTEGER, INTENT(OUT)                 ::  ierr         !<
     393
     394    ierr = 0
     395    CALL MPI_SEND( buf, n, MPI_REAL, client_rank, tag,                         &
     396                   m_to_client_comm(client_id), ierr )
     397
     398 END SUBROUTINE pmc_send_to_client_real_r2
     399
     400
     401
     402 SUBROUTINE pmc_recv_from_client_real_r2( client_id, buf, n, client_rank, tag, &
     403                                          ierr )
     404
     405    IMPLICIT NONE
     406
     407    INTEGER, INTENT(IN)                   ::  client_id    !<
     408    REAL(wp), DIMENSION(:,:), INTENT(OUT) ::  buf          !<
     409    INTEGER, INTENT(IN)                   ::  n            !<
     410    INTEGER, INTENT(IN)                   ::  client_rank  !<
     411    INTEGER, INTENT(IN)                   ::  tag          !<
     412    INTEGER, INTENT(OUT)                  ::  ierr         !<
     413
     414    ierr = 0
     415    CALL MPI_RECV( buf, n, MPI_REAL, client_rank, tag,                         &
     416                   m_to_client_comm(client_id), MPI_STATUS_IGNORE, ierr )
     417
     418 END SUBROUTINE pmc_recv_from_client_real_r2
     419
     420
     421
     422 SUBROUTINE pmc_send_to_client_real_r3( client_id, buf, n, client_rank, tag,   &
     423                                        ierr)
     424
     425    IMPLICIT NONE
     426
     427    INTEGER, INTENT(IN)                    ::  client_id    !<
     428    REAL(wp), DIMENSION(:,:,:), INTENT(IN) ::  buf          !<
     429    INTEGER, INTENT(IN)                    ::  n            !<
     430    INTEGER, INTENT(IN)                    ::  client_rank  !<
     431    INTEGER, INTENT(IN)                    ::  tag          !<
     432    INTEGER, INTENT(OUT)                   ::  ierr         !<
     433
     434    ierr = 0
     435    CALL MPI_SEND( buf, n, MPI_REAL, client_rank, tag,                         &
     436                   m_to_client_comm(client_id), ierr )
     437
     438 END SUBROUTINE pmc_send_to_client_real_r3
     439
     440
     441
     442 SUBROUTINE pmc_recv_from_client_real_r3( client_id, buf, n, client_rank, tag, &
     443                                          ierr )
     444
     445    IMPLICIT NONE
     446
     447    INTEGER, INTENT(IN)                     ::  client_id    !<
     448    REAL(wp), DIMENSION(:,:,:), INTENT(OUT) ::  buf          !<
     449    INTEGER, INTENT(IN)                     ::  n            !<
     450    INTEGER, INTENT(IN)                     ::  client_rank  !<
     451    INTEGER, INTENT(IN)                     ::  tag          !<
     452    INTEGER, INTENT(OUT)                    ::  ierr         !<
     453
     454    ierr = 0
     455    CALL MPI_RECV( buf, n, MPI_REAL, client_rank, tag,                         &
     456                   m_to_client_comm(client_id), MPI_STATUS_IGNORE, ierr )
     457
     458 END SUBROUTINE pmc_recv_from_client_real_r3
     459
     460
     461
     462 SUBROUTINE pmc_bcast_integer( buf, root_pe, comm, ierr )
     463
     464    IMPLICIT NONE
     465
     466    INTEGER, INTENT(INOUT)         ::  buf      !<
     467    INTEGER, INTENT(IN)            ::  root_pe  !<
     468    INTEGER, INTENT(IN), OPTIONAL  ::  comm     !<
     469    INTEGER, INTENT(OUT), OPTIONAL ::  ierr     !<
     470
     471    INTEGER ::  mycomm  !<
     472    INTEGER ::  myerr   !<
     473
     474
     475    IF ( PRESENT( comm ) )  THEN
     476       mycomm = comm
     477    ELSE
     478       mycomm = m_model_comm
     479    ENDIF
     480
     481    CALL MPI_BCAST( buf, 1, MPI_INTEGER, root_pe, mycomm, myerr )
     482
     483    IF ( PRESENT( ierr ) )  THEN
     484       ierr = myerr
     485    ENDIF
     486
     487 END SUBROUTINE pmc_bcast_integer
     488
     489
     490
     491 SUBROUTINE pmc_bcast_character( buf, root_pe, comm, ierr )
     492
     493    IMPLICIT NONE
     494
     495    CHARACTER(LEN=*), INTENT(INOUT) ::  buf      !<
     496    INTEGER, INTENT(IN)             ::  root_pe  !<
     497    INTEGER, INTENT(IN), OPTIONAL   ::  comm     !<
     498    INTEGER, INTENT(OUT), OPTIONAL  ::  ierr     !<
     499
     500    INTEGER ::  mycomm  !<
     501    INTEGER ::  myerr   !<
     502
     503    IF ( PRESENT( comm ) )  THEN
     504       mycomm = comm
     505    ELSE
     506       mycomm = m_model_comm
     507    ENDIF
     508
     509    CALL MPI_BCAST( buf, LEN(buf), MPI_CHARACTER, root_pe, mycomm, myerr )
     510
     511    IF ( PRESENT( ierr ) )  THEN
     512       ierr = myerr
     513    ENDIF
     514
     515 END SUBROUTINE pmc_bcast_character
     516
     517
     518
     519 SUBROUTINE pmc_inter_bcast_integer_1( buf, client_id, ierr )
     520
     521    IMPLICIT NONE
     522
     523    INTEGER, INTENT(INOUT),DIMENSION(:) ::  buf        !<
     524    INTEGER, INTENT(IN),optional        ::  client_id  !<
     525    INTEGER, INTENT(OUT),optional       ::  ierr       !<
     526
     527    INTEGER ::  mycomm   !<
     528    INTEGER ::  myerr    !<
     529    INTEGER ::  root_pe  !<
     530
     531!
     532!-- PE 0 server broadcast to all client PEs
     533    IF ( PRESENT( client_id ) )  THEN
     534
     535       mycomm = m_to_client_comm(client_id)
     536
     537       IF ( m_model_rank == 0 )  THEN
     538          root_pe = MPI_ROOT
     539       ELSE
     540          root_pe = MPI_PROC_NULL
     541       ENDIF
     542
     543    ELSE
     544       mycomm  = m_to_server_comm
     545       root_pe = 0
     546    ENDIF
     547
     548    CALL MPI_BCAST( buf, SIZE( buf ), MPI_INTEGER, root_pe, mycomm, myerr )
     549
     550    IF ( PRESENT( ierr ) )  THEN
     551       ierr = myerr
     552    ENDIF
     553
     554 END SUBROUTINE pmc_inter_bcast_integer_1
     555
     556
     557
     558 SUBROUTINE pmc_alloc_mem_integer_1( iarray, idim1 )
     559!
     560!-- Allocate memory with MPI_ALLOC_MEM using intermediate C-pointer
     561
     562    IMPLICIT NONE
     563
     564    INTEGER, DIMENSION(:), POINTER, INTENT(INOUT) ::  iarray  !<
     565    INTEGER, INTENT(IN)                           ::  idim1   !<
     566
     567    INTEGER, DIMENSION(1)          ::  ashape   !<
     568    INTEGER(KIND=MPI_ADDRESS_KIND) ::  winsize  !<
     569    INTEGER                        ::  ierr     !<
     570
     571    TYPE(C_PTR)                    ::  p_myind  !<
     572
     573    winsize = idim1 * C_SIZEOF( ierr )
     574
     575    CALL MPI_ALLOC_MEM( winsize, MPI_INFO_NULL, p_myind, ierr )
     576    ashape(1) = idim1
     577    CALL C_F_POINTER( p_myind, iarray, ashape )
     578
     579 END SUBROUTINE pmc_alloc_mem_integer_1
     580
     581
     582
     583 SUBROUTINE pmc_alloc_mem_real_1( array, idim1, base_ptr )
     584
     585    IMPLICIT NONE
     586
     587    INTEGER(idp), INTENT(IN)                            ::  idim1     !<
     588    REAL(KIND=wp), DIMENSION(:), POINTER, INTENT(INOUT) ::  array     !<
     589    TYPE(C_PTR), INTENT(OUT), OPTIONAL                  ::  base_ptr  !<
     590
     591    INTEGER, DIMENSION(1)          :: ashape   !<
     592    INTEGER(KIND=MPI_ADDRESS_KIND) :: winsize  !<
     593    INTEGER                        :: ierr     !<
     594
     595    TYPE(C_PTR)                    :: p_myind  !<
     596
     597    winsize = idim1 * wp
     598
     599    CALL MPI_ALLOC_MEM( winsize , MPI_INFO_NULL, p_myind, ierr )
     600    ashape(1) = idim1
     601    CALL C_F_POINTER( p_myind, array, ashape )
     602
     603    IF ( PRESENT( base_ptr ) )  THEN
     604       base_ptr = p_myind
     605    ENDIF
     606
     607 END SUBROUTINE pmc_alloc_mem_Real_1
     608
     609
     610
     611 FUNCTION pmc_time()
     612
     613    REAL(kind=wp) :: pmc_time  !<
     614
     615    pmc_time = MPI_WTIME()
     616
     617  END FUNCTION pmc_time
    555618
    556619#endif
Note: See TracChangeset for help on using the changeset viewer.