computational_environment.f90

Go to the documentation of this file.

MODULE comp_environment

  USE base_routines
  USE cmiss_mpi
  USE cmisspetsc
  USE constants
  USE kinds
#ifndef NOMPIMOD
  USE mpi
#endif
  USE input_output
  USE iso_varying_string
 
#include "macros.h"

  IMPLICIT NONE

#ifdef NOMPIMOD
#include "mpif.h"
#endif

  !Module parameters

  !Module types
  
  TYPE, PUBLIC :: computational_work_group_ptr_type
     TYPE(computational_work_group_type), POINTER :: ptr
  END TYPE computational_work_group_ptr_type
  
  TYPE, PUBLIC :: computational_work_group_type
    INTEGER(INTG) :: number_computational_nodes
    INTEGER(INTG) :: number_sub_work_groups
    TYPE(computational_work_group_type), POINTER:: parent
    TYPE(computational_work_group_ptr_type), ALLOCATABLE:: sub_work_groups(:)
    
    TYPE(computational_environment_type), POINTER :: comp_env
    LOGICAL :: comp_env_finished
  END TYPE computational_work_group_type

  PRIVATE

  TYPE cache_type
    INTEGER(INTG) :: number_levels
    INTEGER(INTG),ALLOCATABLE :: size(:)
  END TYPE cache_type

  TYPE computational_node_type
    INTEGER(INTG) :: number_processors
    INTEGER(INTG) :: rank
   !TYPE(CACHE_TYPE) :: CACHE 
    INTEGER(INTG) :: node_name_length
    CHARACTER(LEN=MPI_MAX_PROCESSOR_NAME) :: node_name
  END TYPE computational_node_type

  PUBLIC computational_node_type

  TYPE mpi_computational_node_type
    INTEGER(INTG) :: mpi_type
    INTEGER(INTG) :: num_blocks
    INTEGER(INTG) :: block_lengths(4)
    INTEGER(INTG) :: types(4)
    INTEGER(MPI_ADDRESS_KIND) :: displacements(4)
  END TYPE mpi_computational_node_type

  TYPE computational_environment_type
    INTEGER(INTG) :: mpi_comm
    INTEGER(INTG) :: number_computational_nodes
    INTEGER(INTG) :: my_computational_node_number
    TYPE(computational_node_type), ALLOCATABLE :: computational_nodes(:)
  END TYPE computational_environment_type

  !Module variables

  TYPE(computational_environment_type), TARGET :: computational_environment
  TYPE(mpi_computational_node_type) :: mpi_computational_node_type_data

  !Interfaces
  ! Access specifiers for subroutines and interfaces(if any)
  PUBLIC computational_environment_type
  PUBLIC computational_environment
  PUBLIC computational_environment_initialise,computational_environment_finalise,computational_nodes_number_get, &
    & computational_node_number_get
  PUBLIC computational_work_group_subgroup_add, computational_work_group_create_start, computational_work_group_create_finish

CONTAINS
  !
  !================================================================================================================================
  !

  SUBROUTINE computational_work_group_subgroup_add(PARENT_WORK_GROUP, NUMBER_COMPUTATIONAL_NODES, &
   & added_work_group,err,error,*)

    !Argument Variables
    TYPE(computational_work_group_type),POINTER, INTENT(INOUT) :: PARENT_WORK_GROUP
    TYPE(computational_work_group_type),POINTER, INTENT(INOUT) :: ADDED_WORK_GROUP
    INTEGER(INTG),INTENT(IN) :: NUMBER_COMPUTATIONAL_NODES
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string), INTENT(OUT) :: ERROR
    !Local Variables
    TYPE(computational_work_group_ptr_type) NEW_WORK_GROUP
    TYPE(computational_work_group_type),POINTER ::  TMP_PARENT_WORK_GROUP
    TYPE(computational_work_group_ptr_type), ALLOCATABLE :: SUB_WORK_GROUPS(:)
    INTEGER(INTG):: I

    ALLOCATE(new_work_group%PTR)
    new_work_group%PTR%NUMBER_COMPUTATIONAL_NODES = number_computational_nodes
    new_work_group%PTR%NUMBER_SUB_WORK_GROUPS = 0

    IF(ASSOCIATED(parent_work_group)) THEN 
      ALLOCATE(sub_work_groups(parent_work_group%NUMBER_SUB_WORK_GROUPS+1))
      DO i=1,parent_work_group%NUMBER_SUB_WORK_GROUPS
        sub_work_groups(i)%PTR=>parent_work_group%SUB_WORK_GROUPS(i)%PTR
      ENDDO
      !SUB_WORK_GROUPS(1:PARENT_WORK_GROUP%NUMBER_SUB_WORK_GROUPS)=>PARENT_WORK_GROUP%SUB_WORK_GROUPS(:)
      
      IF(ALLOCATED(parent_work_group%SUB_WORK_GROUPS)) THEN 
        DEALLOCATE(parent_work_group%SUB_WORK_GROUPS)
      ENDIF
      sub_work_groups(1+parent_work_group%NUMBER_SUB_WORK_GROUPS)%PTR=>new_work_group%PTR
      ALLOCATE(parent_work_group%SUB_WORK_GROUPS(SIZE(sub_work_groups,1)))
      DO i=1,SIZE(sub_work_groups,1)
        parent_work_group%SUB_WORK_GROUPS(i)%PTR => sub_work_groups(i)%PTR
      ENDDO
      !PARENT_WORK_GROUP%SUB_WORK_GROUPS(:) => SUB_WORK_GROUPS(:)
      
      DEALLOCATE(sub_work_groups)
      parent_work_group%NUMBER_SUB_WORK_GROUPS = 1+parent_work_group%NUMBER_SUB_WORK_GROUPS
      new_work_group%PTR%PARENT => parent_work_group
      tmp_parent_work_group => parent_work_group 
      DO WHILE(ASSOCIATED(tmp_parent_work_group)) !Update the computational number of its ancestors
        tmp_parent_work_group%NUMBER_COMPUTATIONAL_NODES = tmp_parent_work_group%NUMBER_COMPUTATIONAL_NODES &
          & + new_work_group%PTR%NUMBER_COMPUTATIONAL_NODES
        tmp_parent_work_group => tmp_parent_work_group%PARENT
      ENDDO
    ELSE !Top level group
      CALL flagerror('PARENT_WORK_GROUP is not associated, call COMPUTATIONAL_WORK_GROUP_CREATE_START first',&
      & err,error,*999)
    ENDIF
    added_work_group => new_work_group%PTR

    exits("COMPUTATIONAL_WORK_GROUP_SUBGROUP_ADD")
    RETURN
999 errorsexits("COMPUTATIONAL_WORK_GROUP_SUBGROUP_ADD",err,error)
    RETURN 1
  END SUBROUTINE computational_work_group_subgroup_add

  !
  !================================================================================================================================
  !

  SUBROUTINE computational_work_group_create_start(WORLD_WORK_GROUP,NUMBER_COMPUTATIONAL_NODES,ERR,ERROR,*)

    !Argument Variables
    TYPE(computational_work_group_type),POINTER, INTENT(INOUT) :: WORLD_WORK_GROUP
    INTEGER(INTG),INTENT(IN) :: NUMBER_COMPUTATIONAL_NODES
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string), INTENT(OUT) :: ERROR
    !Local Variables
    TYPE(computational_work_group_ptr_type) NEW_WORK_GROUP

    IF(ASSOCIATED(world_work_group)) THEN 
      CALL flagerror('WORLD_WORK_GROUP is already associated', err, error, *999)
    ELSE
      ALLOCATE(new_work_group%PTR)
      new_work_group%PTR%NUMBER_COMPUTATIONAL_NODES = number_computational_nodes
      new_work_group%PTR%NUMBER_SUB_WORK_GROUPS = 0   
      NULLIFY(new_work_group%PTR%PARENT) !It is the highest level work group already 
      NULLIFY(new_work_group%PTR%COMP_ENV) !Generate this later in COMPUTATIONAL_WORK_GROUP_CREATE_FINISH
      world_work_group=>new_work_group%PTR
    ENDIF
    
    exits("COMPUTATIONAL_WORK_GROUP_CREATE_START")
    RETURN
999 errorsexits("COMPUTATIONAL_WORK_GROUP_CREATE_START",err,error)
    RETURN 1
  END SUBROUTINE computational_work_group_create_start

  !
  !================================================================================================================================
  !

  RECURSIVE SUBROUTINE computational_workgroupgeneratecompenviron(WORK_GROUP,AVAILABLE_RANK_LIST,ERR,ERROR,*)

    !Argument Variables
    TYPE(computational_work_group_type),POINTER, INTENT(INOUT) :: WORK_GROUP
    INTEGER(INTG), ALLOCATABLE, INTENT(INOUT) :: AVAILABLE_RANK_LIST(:)
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string), INTENT(OUT) :: ERROR
    !Local Variables
    INTEGER(INTG) :: I,MPI_IERROR,RANK,ORIGINAL_GROUP,NEW_GROUP
    INTEGER(INTG), ALLOCATABLE :: NEW_AVAILABLE_RANK_LIST(:)
    
    enters("Computational_WorkGroupGenerateCompEnviron",err,error,*999)
    
    ALLOCATE(work_group%COMP_ENV)

    !Set size of computational nodes in this communicator
    work_group%COMP_ENV%NUMBER_COMPUTATIONAL_NODES = work_group%NUMBER_COMPUTATIONAL_NODES
    
    !Determine my processes rank
    CALL mpi_comm_rank(computational_environment%MPI_COMM,rank,mpi_ierror)
    CALL mpi_error_check("MPI_COMM_RANK",mpi_ierror,err,error,*999)
    work_group%COMP_ENV%MY_COMPUTATIONAL_NODE_NUMBER=rank
    
    !Fill in the information for every computational node in this group
    ALLOCATE(work_group%COMP_ENV%COMPUTATIONAL_NODES(work_group%COMP_ENV%NUMBER_COMPUTATIONAL_NODES))
    i=SIZE(available_rank_list,1)
    IF(SIZE(available_rank_list,1)-work_group%COMP_ENV%NUMBER_COMPUTATIONAL_NODES < 0) THEN
      CALL flagerror("NOT ENOUGH RANKS", err, error, *999)
      GOTO 999
    ENDIF
    DO i=1,work_group%COMP_ENV%NUMBER_COMPUTATIONAL_NODES, 1
      work_group%COMP_ENV%COMPUTATIONAL_NODES(i) = computational_environment%COMPUTATIONAL_NODES(available_rank_list(i))
    ENDDO

    !Create a communicator
    !CALL MPI_COMM_DUP(MPI_COMM_WORLD,WORK_GROUP%COMP_ENV%MPI_COMM,MPI_IERROR)
    CALL mpi_comm_group(mpi_comm_world,original_group,mpi_ierror);
    CALL mpi_error_check("MPI_COMM_RANK",mpi_ierror,err,error,*999)    
    CALL mpi_group_incl(original_group,i-1,available_rank_list(1:i-1),new_group,mpi_ierror)  !Choose the first I-1 ranks
    CALL mpi_error_check("MPI_COMM_RANK",mpi_ierror,err,error,*999)    
    CALL mpi_comm_create(mpi_comm_world,new_group,work_group%COMP_ENV%MPI_COMM,mpi_ierror)
    CALL mpi_error_check("MPI_COMM_RANK",mpi_ierror,err,error,*999)    
    CALL mpi_group_free(original_group,mpi_ierror)
    CALL mpi_error_check("MPI_COMM_RANK",mpi_ierror,err,error,*999)    
    CALL mpi_group_free(new_group,mpi_ierror) 
    CALL mpi_error_check("MPI_COMM_RANK",mpi_ierror,err,error,*999)    

    !Shrink the AVAILABLE_RANK_LIST
    ALLOCATE(new_available_rank_list(SIZE(available_rank_list,1)-work_group%COMP_ENV%NUMBER_COMPUTATIONAL_NODES))  
    new_available_rank_list(1:SIZE(new_available_rank_list)) = available_rank_list(i:SIZE(available_rank_list,1))
    DEALLOCATE(available_rank_list)
    ALLOCATE(available_rank_list(SIZE(new_available_rank_list,1)))
    available_rank_list(:) = new_available_rank_list(:)

    work_group%COMP_ENV_FINISHED = .true.

    !Recursively do this to all its subgroups
    DO i=1,work_group%NUMBER_SUB_WORK_GROUPS,1
      CALL computational_workgroupgeneratecompenviron(work_group%SUB_WORK_GROUPS(i)%PTR,&
        & available_rank_list,err,error,*999)      
    ENDDO

    exits("Computational_WorkGroupGenerateCompEnviron")
    RETURN
999 errorsexits("Computational_WorkGroupGenerateCompEnviron",err,error)
    RETURN 1
    
  END SUBROUTINE computational_workgroupgeneratecompenviron

  !
  !================================================================================================================================
  !

  SUBROUTINE computational_work_group_create_finish(WORLD_WORK_GROUP,ERR,ERROR,*)

    !Argument Variables
    TYPE(computational_work_group_type),POINTER,INTENT(INOUT) :: WORLD_WORK_GROUP
    INTEGER(INTG),INTENT(OUT) :: ERR
    TYPE(varying_string),INTENT(OUT) :: ERROR
    !Local Variables
    INTEGER(INTG),ALLOCATABLE:: AVAILABLE_RANK_LIST(:)
    INTEGER(INTG) :: I

    enters("COMPUTATIONAL_WORK_GROUP_CREATE_FINISH",err,error,*999)

    !set the computational environment of the world work group to be the global COMPUTATIONAL_ENVIRONMENT (the default communicator in OpenCMISS)
    world_work_group%COMP_ENV => computational_environment 
    world_work_group%COMP_ENV_FINISHED = .true.

    !generate the communicators for subgroups if any
    ALLOCATE(available_rank_list(world_work_group%COMP_ENV%NUMBER_COMPUTATIONAL_NODES))
    DO i=0,SIZE(available_rank_list,1)-1
      available_rank_list(i+1) = i
    END DO
    DO i=1,world_work_group%NUMBER_SUB_WORK_GROUPS,1
      CALL computational_workgroupgeneratecompenviron(world_work_group%SUB_WORK_GROUPS(i)%PTR,available_rank_list,err,error,*999)
    END DO

    exits("COMPUTATIONAL_WORK_GROUP_CREATE_FINISH")
    RETURN
999 errorsexits("COMPUTATIONAL_WORK_GROUP_CREATE_FINISH",err,error)
    RETURN 1
  END SUBROUTINE computational_work_group_create_finish

  !
  !================================================================================================================================
  !

  SUBROUTINE computational_node_finalise(COMPUTATIONAL_NODE,ERR,ERROR,*)
  
    !Argument Variables
    TYPE(computational_node_type),INTENT(INOUT) :: COMPUTATIONAL_NODE
    INTEGER(INTG),INTENT(OUT) :: ERR
    TYPE(varying_string),INTENT(OUT) :: ERROR
    !Local Variables

    enters("COMPUTATIONAL_NODE_FINALISE",err,error,*999)

    computational_node%NUMBER_PROCESSORS=0
    computational_node%RANK=-1
    computational_node%NODE_NAME_LENGTH=0
    computational_node%NODE_NAME=""    

    exits("COMPUTATIONAL_NODE_FINALISE")
    RETURN
999 errorsexits("COMPUTATIONAL_NODE_FINALISE",err,error)
    RETURN 1
  END SUBROUTINE computational_node_finalise

  !
  !================================================================================================================================
  !

  SUBROUTINE computational_node_initialise(COMPUTATIONAL_NODE,RANK,ERR,ERROR,*)
  
    !Argument Variables
    TYPE(computational_node_type), INTENT(OUT) :: COMPUTATIONAL_NODE
    INTEGER(INTG), INTENT(IN) :: RANK
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string), INTENT(OUT) :: ERROR
    !Local Variables
    INTEGER(INTG) :: MPI_IERROR

    enters("COMPUTATIONAL_NODE_INITIALISE",err,error,*999)

!    COMPUTATIONAL_NODE%NUMBER_PROCESSORS=COMP_DETECT_NUMBER_PROCESSORS(ERR)
!    IF(ERR/=0) GOTO 999
    computational_node%NUMBER_PROCESSORS=1
    computational_node%RANK=rank
    CALL mpi_get_processor_name(computational_node%NODE_NAME,computational_node%NODE_NAME_LENGTH,mpi_ierror)
    CALL mpi_error_check("MPI_GET_PROCESSOR_NAME",mpi_ierror,err,error,*999)
    
    exits("COMPUTATIONAL_NODE_INITIALISE")
    RETURN
999 errorsexits("COMPUTATIONAL_NODE_INITIALISE",err,error)
    RETURN 1
  END SUBROUTINE computational_node_initialise

  !
  !================================================================================================================================
  !

  SUBROUTINE computational_node_mpi_type_finalise(ERR,ERROR,*)
  
    !Argument Variables
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string), INTENT(OUT) :: ERROR
    !Local Variables
    INTEGER(INTG) :: i,MPI_IERROR

    enters("COMPUTATIONAL_NODE_MPI_TYPE_FINALISE",err,error,*999)

    DO i=1,mpi_computational_node_type_data%NUM_BLOCKS
      mpi_computational_node_type_data%TYPES(i)=0
      mpi_computational_node_type_data%BLOCK_LENGTHS(i)=0
      mpi_computational_node_type_data%DISPLACEMENTS(i)=0
    ENDDO !i
    mpi_computational_node_type_data%NUM_BLOCKS=0

    IF(mpi_computational_node_type_data%MPI_TYPE/=mpi_datatype_null) THEN
      CALL mpi_type_free(mpi_computational_node_type_data%MPI_TYPE,mpi_ierror)
      CALL mpi_error_check("MPI_TYPE_FREE",mpi_ierror,err,error,*999)
    ENDIF

    exits("COMPUTATIONAL_NODE_MPI_TYPE_FINALISE")
    RETURN
999 errorsexits("COMPUTATIONAL_NODE_MPI_TYPE_FINALISE",err,error)
    RETURN 1
  END SUBROUTINE computational_node_mpi_type_finalise

  !
  !================================================================================================================================
  !

  SUBROUTINE computational_node_mpi_type_initialise(COMPUTATIONAL_NODE,ERR,ERROR,*)
  
    !Argument Variables
    TYPE(computational_node_type), INTENT(IN) :: COMPUTATIONAL_NODE
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string), INTENT(OUT) :: ERROR
    !Local Variables
    INTEGER(INTG) :: I,MPI_IERROR

    enters("COMPUTATIONAL_NODE_MPI_TYPE_INITIALISE",err,error,*999)

    mpi_computational_node_type_data%MPI_TYPE=mpi_datatype_null
    
    mpi_computational_node_type_data%NUM_BLOCKS=4
    mpi_computational_node_type_data%TYPES=(/mpi_integer,mpi_integer,mpi_integer,mpi_character/)
    mpi_computational_node_type_data%BLOCK_LENGTHS=(/1,1,1,mpi_max_processor_name/)
  
  
    CALL mpi_get_address(computational_node%NUMBER_PROCESSORS,mpi_computational_node_type_data%DISPLACEMENTS(1),mpi_ierror)
    CALL mpi_error_check("MPI_GET_ADDRESS",mpi_ierror,err,error,*999)
    CALL mpi_get_address(computational_node%RANK,mpi_computational_node_type_data%DISPLACEMENTS(2),mpi_ierror)
    CALL mpi_error_check("MPI_GET_ADDRESS",mpi_ierror,err,error,*999)
    CALL mpi_get_address(computational_node%NODE_NAME_LENGTH,mpi_computational_node_type_data%DISPLACEMENTS(3),mpi_ierror)
    CALL mpi_error_check("MPI_GET_ADDRESS",mpi_ierror,err,error,*999)
    !CPB 19/02/07 AIX compiler complains about the type of the first parameter i.e., the previous 3 have been integers
    !and this one is not so cast the type.
    CALL mpi_get_address(computational_node%NODE_NAME,mpi_computational_node_type_data%DISPLACEMENTS(4),mpi_ierror)
    CALL mpi_error_check("MPI_GET_ADDRESS",mpi_ierror,err,error,*999)

    DO i=4,1,-1
      mpi_computational_node_type_data%DISPLACEMENTS(i)=mpi_computational_node_type_data%DISPLACEMENTS(i)- &
        & mpi_computational_node_type_data%DISPLACEMENTS(1)
    ENDDO !i

    CALL mpi_type_create_struct(mpi_computational_node_type_data%NUM_BLOCKS,mpi_computational_node_type_data%BLOCK_LENGTHS, &
      & mpi_computational_node_type_data%DISPLACEMENTS,mpi_computational_node_type_data%TYPES, &
      & mpi_computational_node_type_data%MPI_TYPE,mpi_ierror)
    CALL mpi_error_check("MPI_TYPE_CREATE_STRUCT",mpi_ierror,err,error,*999)

    CALL mpi_type_commit(mpi_computational_node_type_data%MPI_TYPE, mpi_ierror)
    CALL mpi_error_check("MPI_TYPE_COMMIT",mpi_ierror,err,error,*999)
    
    IF(diagnostics3) THEN
      CALL write_string(diagnostic_output_type,"MPI Computational Node Type Data:",err,error,*999)
      CALL write_string_value(diagnostic_output_type,"  MPI type = ",mpi_computational_node_type_data%MPI_TYPE,err,error,*999)
      CALL write_string_value(diagnostic_output_type,"  Number blocks  = ",mpi_computational_node_type_data%NUM_BLOCKS, &
        & err,error,*999)
      CALL write_string_vector(diagnostic_output_type,1,1,mpi_computational_node_type_data%NUM_BLOCKS,4,4, &
        & mpi_computational_node_type_data%TYPES,'("  Block types =",4(X,I15))','(15X,4(X,I15))',err,error,*999)
      CALL write_string_vector(diagnostic_output_type,1,1,mpi_computational_node_type_data%NUM_BLOCKS,8,8, &
        & mpi_computational_node_type_data%BLOCK_LENGTHS,'("  Block lengths =",8(X,I5))','(17X,8(X,I5))',err,error,*999)
      CALL write_string_vector(diagnostic_output_type,1,1,mpi_computational_node_type_data%NUM_BLOCKS,8,8, &
        & mpi_computational_node_type_data%DISPLACEMENTS,'("  Displacements =",8(X,I5))','(17X,8(X,I5))',err,error,*999)
    ENDIF

    exits("COMPUTATIONAL_NODE_MPI_TYPE_INITIALISE")
    RETURN
999 CALL computational_node_mpi_type_finalise(err,error,*998)
998 errorsexits("COMPUTATIONAL_NODE_MPI_TYPE_INITIALISE",err,error)
    RETURN 1
  END SUBROUTINE computational_node_mpi_type_initialise

  !
  !================================================================================================================================
  !

  SUBROUTINE computational_environment_finalise(ERR,ERROR,*)

    !Argument Variables
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string), INTENT(OUT) :: ERROR
    !Local Variables
    INTEGER(INTG) :: COMPUTATIONAL_NODE,MPI_IERROR

    enters("COMPUTATIONAL_ENVIRONMENT_FINALISE",err,error,*999)

    IF(ALLOCATED(computational_environment%COMPUTATIONAL_NODES)) THEN
       DO computational_node=0,computational_environment%NUMBER_COMPUTATIONAL_NODES-1
          CALL computational_node_finalise(computational_environment%COMPUTATIONAL_NODES(computational_node),err,error,*999)
       ENDDO
       DEALLOCATE(computational_environment%COMPUTATIONAL_NODES)
    ENDIF
    computational_environment%NUMBER_COMPUTATIONAL_NODES=0

    CALL computational_node_mpi_type_finalise(err,error,*999)

    CALL mpi_comm_free(computational_environment%MPI_COMM,mpi_ierror)
    CALL mpi_error_check("MPI_COMM_FREE",mpi_ierror,err,error,*999)

    !Finalise PetSc
    !Call this after MPI_COMM_FREE as PETSc routines are called when some
    !MPI comm attributes are freed.
    !CALL Petsc_LogView(PETSC_COMM_WORLD,"OpenCMISSTest.petsc",ERR,ERROR,*999)
    CALL petsc_finalise(err,error,*999)

    CALL mpi_finalize(mpi_ierror)
    CALL mpi_error_check("MPI_FINALIZE",mpi_ierror,err,error,*999)

    exits("COMPUTATIONAL_ENVIRONMENT_FINALISE")
    RETURN
999 errorsexits("COMPUTATIONAL_ENVIRONMENT_FINALISE",err,error)
    RETURN 1
  END SUBROUTINE computational_environment_finalise

  !
  !================================================================================================================================
  !

  SUBROUTINE computational_environment_initialise(ERR,ERROR,*)

    !Argument Variables
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string), INTENT(OUT) :: ERROR
    !Local Variables
    INTEGER(INTG) :: i,DUMMY_ERR,MPI_IERROR,RANK
    TYPE(varying_string) :: DUMMY_ERROR

    enters("COMPUTATIONAL_ENVIRONMENT_INITIALISE",err,error,*999)

    !Initialise the MPI environment
    CALL mpi_init(mpi_ierror)
    CALL mpi_error_check("MPI_INIT",mpi_ierror,err,error,*999)

    !Create a (private) communicator for cmiss. For now just duplicate MPI_COMM_WORLD
    CALL mpi_comm_dup(mpi_comm_world,computational_environment%MPI_COMM,mpi_ierror)
    CALL mpi_error_check("MPI_COMM_DUP",mpi_ierror,err,error,*999)
    
    !Determine the number of ranks/computational nodes we have in our computational environment
    CALL mpi_comm_size(computational_environment%MPI_COMM,computational_environment%NUMBER_COMPUTATIONAL_NODES,mpi_ierror)
    CALL mpi_error_check("MPI_COMM_SIZE",mpi_ierror,err,error,*999)

    !Allocate the computational node data structures
    ALLOCATE(computational_environment%COMPUTATIONAL_NODES(0:computational_environment%NUMBER_COMPUTATIONAL_NODES-1),stat=err)
    IF(err /=0) CALL flagerror("Could not allocate computational nodes",err,error,*999)

    !Determine my processes rank
    CALL mpi_comm_rank(computational_environment%MPI_COMM,rank,mpi_ierror)
    CALL mpi_error_check("MPI_COMM_RANK",mpi_ierror,err,error,*999)
    computational_environment%MY_COMPUTATIONAL_NODE_NUMBER=rank
    
#ifdef TAUPROF
    CALL tau_profile_set_node(rank)
#endif

    !Create the MPI type information for the COMPUTATIONAL_NODE_TYPE
    CALL computational_node_mpi_type_initialise(computational_environment%COMPUTATIONAL_NODES(rank),err,error,*999)
    !Fill in all the computational node data structures for this rank at the root position (will be changed later with an
    !allgather call)
    CALL computational_node_initialise(computational_environment%COMPUTATIONAL_NODES(0),rank,err,error,*999)

!     !Now transfer all the computational node information to the other computational nodes so that each rank has all the
!     !information.
! !!    CALL MPI_ALLGATHER(COMPUTATIONAL_ENVIRONMENT%COMPUTATIONAL_NODES(0),1,MPI_COMPUTATIONAL_NODE_TYPE_DATA%MPI_TYPE, &
! !!      & COMPUTATIONAL_ENVIRONMENT%COMPUTATIONAL_NODES(0),1,MPI_COMPUTATIONAL_NODE_TYPE_DATA%MPI_TYPE, &
! !!      & COMPUTATIONAL_ENVIRONMENT%MPI_COMM,MPI_IERROR)
!     CALL MPI_ALLGATHER(MPI_IN_PLACE,1,MPI_COMPUTATIONAL_NODE_TYPE_DATA%MPI_TYPE, &
!       & COMPUTATIONAL_ENVIRONMENT%COMPUTATIONAL_NODES(0),1,MPI_COMPUTATIONAL_NODE_TYPE_DATA%MPI_TYPE, &
!       & COMPUTATIONAL_ENVIRONMENT%MPI_COMM,MPI_IERROR)
!     CALL WRITE_STRING(DIAGNOSTIC_OUTPUT_TYPE,"    Calling MPI_ERROR_CHECK...",ERR,ERROR,*999)
!     CALL MPI_ERROR_CHECK("MPI_ALLGATHER",MPI_IERROR,ERR,ERROR,*999)

    !Initialise node numbers in base routines.
    CALL computational_node_numbers_set(computational_environment%MY_COMPUTATIONAL_NODE_NUMBER,computational_environment% &
      & number_computational_nodes,err,error,*999)
    
    !Initialise PETSc
    CALL petsc_initialise(petsc_null_character,err,error,*999)
    
    IF(diagnostics1) THEN
      !Just let the master node write out this information
      IF(rank==0) THEN
        CALL write_string(diagnostic_output_type,"Computational environment:",err,error,*999)
        CALL write_string_value(diagnostic_output_type,"  Number of computational nodes = ", &
          & computational_environment%NUMBER_COMPUTATIONAL_NODES,err,error,*999)
        CALL write_string_value(diagnostic_output_type,"  My computational node number = ", &
          & computational_environment%MY_COMPUTATIONAL_NODE_NUMBER,err,error,*999)
        IF(diagnostics2) THEN
          DO i=0,computational_environment%NUMBER_COMPUTATIONAL_NODES-1
            CALL write_string(diagnostic_output_type,"  Computational Node:",err,error,*999)
            CALL write_string_value(diagnostic_output_type,"    Number of Processors = ", &
              & computational_environment%COMPUTATIONAL_NODES(i)%NUMBER_PROCESSORS,err,error,*999)
            CALL write_string_value(diagnostic_output_type,"    MPI rank = ", &
             & computational_environment%COMPUTATIONAL_NODES(i)%RANK,err,error,*999)
            CALL write_string_value(diagnostic_output_type,"    Node Name = ", &
              & computational_environment%COMPUTATIONAL_NODES(i)%NODE_NAME,err,error,*999)
          ENDDO !i
        ENDIF
      ENDIF
    ENDIF

    exits("COMPUTATIONAL_ENVIRONMENT_INITIALISE")
    RETURN
999 CALL computational_environment_finalise(dummy_err,dummy_error,*998)
998 errorsexits("COMPUTATIONAL_ENVIRONMENT_INITIALISE",err,error)
    RETURN 1
  END SUBROUTINE computational_environment_initialise

  !
  !================================================================================================================================
  !

  FUNCTION computational_node_number_get(ERR,ERROR)
      
    !Argument Variables
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string), INTENT(OUT) :: ERROR
    !Function variable
    INTEGER(INTG) :: COMPUTATIONAL_NODE_NUMBER_GET
    !Local Variables

    enters("COMPUTATIONAL_NODE_NUMBER_GET",err,error,*999)

    IF(ALLOCATED(computational_environment%COMPUTATIONAL_NODES)) THEN
      computational_node_number_get=computational_environment%MY_COMPUTATIONAL_NODE_NUMBER
    ELSE
      CALL flagerror("Computational environment not initialised",err,error,*999)
    ENDIF
    
    exits("COMPUTATIONAL_NODE_NUMBER_GET")
    RETURN
999 errorsexits("COMPUTATIONAL_NODE_NUMBER_GET",err,error)
    RETURN 
  END FUNCTION computational_node_number_get

  !
  !================================================================================================================================
  !
  
  FUNCTION computational_nodes_number_get(ERR,ERROR)
     
    !Argument Variables
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string), INTENT(OUT) :: ERROR
    !Function variable
    INTEGER(INTG) :: COMPUTATIONAL_NODES_NUMBER_GET
    !Local Variables

    enters("COMPUTATIONAL_NODES_NUMBER_GET",err,error,*999)

    IF(ALLOCATED(computational_environment%COMPUTATIONAL_NODES)) THEN
      computational_nodes_number_get=computational_environment%NUMBER_COMPUTATIONAL_NODES
    ELSE
      CALL flagerror("Computational environment not initialised",err,error,*999)
    ENDIF
    
    exits("COMPUTATIONAL_NODES_NUMBER_GET")
    RETURN
999 errorsexits("COMPUTATIONAL_NODES_NUMBER_GET",err,error)
    RETURN 
  END FUNCTION computational_nodes_number_get

  !
  !================================================================================================================================
  !

END MODULE comp_environment