#ifndef ___FNAME_H__200211212355_OJLWEFOSDF__INCLUDED___
#define ___FNAME_H__200211212355_OJLWEFOSDF__INCLUDED___

/* C のコード中で FORTRAN77 との名前付け規則の違いを */
/* 吸収するために使うマクロ */
/* コンパイラによって定義が変わることがあります */
#define FNAME(func)    func##_

#endif  /* #ifndef ___FNAME_H__200211212355_OJLWEFOSDF__INCLUDED___ */

#ifndef ___CNAME_H__200211212355_KJFOEJOIDS__INCLUDED___
#define ___CNAME_H__200211212355_KJFOEJOIDS__INCLUDED___

/* FORTRAN77 のコード中で C との名前付け規則の違いを */
/* 吸収するために使うマクロ */
/* コンパイラによって定義が変わることがあります */
#define CNAME(func)    func

#endif  /* #ifndef ___CNAME_H__200211212355_KJFOEJOIDS__INCLUDED___ */

#include <stdlib.h>
#include "fname.h"

/* FORTRAN77 で乱数を使うために作った関数 */
int FNAME(random)()
{
  return rand();
}

      Include 'mpif.h'

C     新しいデータ型のテスト用通信タグ
      Integer TAG_NEWTYPE
        Parameter (TAG_NEWTYPE = 0)

C     受信バッファサイズ
      Integer BUF_SIZE
        Parameter (BUF_SIZE = 64)

C     送信側のランク
      Integer RANK_SENDER
        Parameter (RANK_SENDER = 0)
C     受信側のランク
      Integer RANK_RECVER
        Parameter (RANK_RECVER = 1)

C     新しい型のサイズ
      Integer NEWTYPE_SIZE
        Parameter (NEWTYPE_SIZE = 2)

#include "cname.h"

C     MPI の新しいデータ型を作成、登録します
      Subroutine CreateNewType(newType)
      Implicit None
      Include 'params.h'
      Integer newType

        Integer err

        Call MPI_Type_contiguous(
     *    NEWTYPE_SIZE, MPI_INTEGER, newType, err)
        Call MPI_Type_commit(newType, err)

        Return
      End

C     MPI の新しいデータ型を開放します
      Subroutine FreeNewType(newType)
      Implicit None
      Include 'params.h'
      Integer newType

        Integer err

        Call MPI_Type_free(newType, err)

        Return
      End

C     新しい型の配列を乱数で初期化します
      Subroutine InitNewType(data, size)
      Implicit None
      Include 'params.h'
      Integer size
      Integer data(NEWTYPE_SIZE, size)
      Integer CNAME(Random)

        Integer i, j

        Do i = 1, size
          Do j = 1, NEWTYPE_SIZE
            data(j, i) = CNAME(Random)()
          EndDo
        EndDo

        Return
      End

C     新しい型の配列を表示します
      Subroutine OutputNewType(data, size)
      Implicit None
      Include 'params.h'
      Integer size
      Integer data(NEWTYPE_SIZE, size)

        Integer i, j

        Do i = 1, size
          Write(*, *) '  ', i, ': <',
     *      (data(j, i), ',', j = 1, NEWTYPE_SIZE), '\b>'
        End Do

        Return
      End

C     送信
      Subroutine Send(newType)
      Implicit None
      Include 'params.h'
      Integer newType

        Integer   err
        Integer   DATA_SIZE
          Parameter (DATA_SIZE = 9)
        Integer   data(NEWTYPE_SIZE, DATA_SIZE)

C       送信するデータを作成し、出力します
        Call InitNewType(data, DATA_SIZE)
        Write(*, *) 'Sended data     :'
        Call OutputNewType(data, DATA_SIZE)

C       データ型に newType を指定します
        Call MPI_Send(data, DATA_SIZE, newType,
     *                RANK_RECVER, TAG_NEWTYPE, MPI_COMM_WORLD, err)

        Return
      End

C     受信
      Subroutine Recv(newType)
      Implicit None
      Include 'params.h'
      Integer newType

        Integer   err
        Integer   data(NEWTYPE_SIZE, BUF_SIZE)
        Integer   status(MPI_STATUS_SIZE)
        Integer   recvCount
        Integer   i

C       データ型に newType を指定します
        Call MPI_Recv(data, BUF_SIZE, newType, RANK_SENDER,
     *                TAG_NEWTYPE, MPI_COMM_WORLD, status, err)
        Call MPI_Get_count(status, newType, recvCount, err)

        Write(*, *) 'Received count : ', recvCount
        Write(*, *) 'Received data  :'
        Call OutputNewType(data, recvCount)

        Return
      End

      Program TestLAM
      Implicit None
      Include 'params.h'

        Integer err
        Integer rank
C       新しい MPI のデータ型
        Integer newType

        Call MPI_Init(err)
        Call MPI_Comm_rank(MPI_COMM_WORLD, rank, err)

C       新しいデータ型を作成、登録します
        Call CreateNewType(newType)
        If(rank .eq. RANK_SENDER) Then
          Call Send(newType)
        Else If(rank .eq. RANK_RECVER) Then
          Call Recv(newType)
        EndIf
C       新しいデータ型の登録を解除します
        Call FreeNewType(newType)

        Call MPI_Finalize(err)

        Write(*, *) 'Exit : ', rank

        Stop
      End