prism_init.F90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright 2006-2010, CERFACS, Toulouse, France.
! Copyright 2006-2010, SGI Germany, Munich, Germany.
! Copyright 2006-2010, NEC Europe Ltd., London, UK.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!
#ifdef DONT_HAVE_STDMPI2
#define PRISM_with_MPI1
#endif
!
!BOP
!
! Copyright 2004,2005 by CERFACS, NEC-CCRLE, SGI Germany, NEC HPCE, and CNRS
!
! This software and ancillary information called OASIS4 is free
! software.  The public may copy, distribute, use, prepare derivative
! works and publicly display OASIS4 under the terms of the Lesser GNU
! General Public License (LGPL) as published by the Free Software
! Foundation, provided that this notice and any statement of authorship
! are reproduced on all copies. If OASIS4 is modified to produce
! derivative works, such modified software should be clearly marked, so
! as not to confuse it with the current OASIS4 version.

! The developers of the OASIS4 software attempt to build a parallel,
! modular, and user-friendly coupler accessible to the climate modelling
! community. Although we use the tool ourselves and have made every
! effort to ensure its accuracy, we can not make any guarantees. The
! software is provided for free; in return, the user assume full
! responsibility for use of the software. The OASIS4 software comes
! without any warranties (implied or expressed) and is not guaranteed to
! work for you or on your computer.  CERFACS, NEC-CCRLE, SGI Germany,
! and NEC HPCE and the various individuals involved in development and
! maintenance of the OASIS4 software are not responsible for any damage
! that may result from correct or incorrect use of this software.
!
! !ROUTINE: PRISM_Init
!
! !INTERFACE:
!
      subroutine prism_init ( appl_name, ierror )
!
! !USES:
!
      use PRISM, dummy_interface => prism_init
!
      use PSMILe
!
      use psmile_user_data, only : psmile_user_data_init
!
      use psmile_timer, only : psmile_timer_init, psmile_timer_start

      implicit none
!
! !INPUT PARAMETERS:
!
      character(len=*), Intent (In)       :: appl_name
!
! !OUTPUT PARAMETERS:
!
      integer, Intent (Out)               :: ierror
!
!     Returns the error code of prism_init;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
!
! !LOCAL VARIABLES
!
      integer                             :: i, j, k, ipos, index
      integer                             :: intercomm
      integer                             :: comp_index

      logical                             :: flag
      integer, parameter                  :: nerrp = 3
      integer                             :: ierrp (nerrp)

      integer                             :: parallel_io
      logical                             :: output_into_file
      logical, save                       :: called

      integer                             :: lenstr

      integer                             :: ndibuf
      integer, dimension (:), allocatable :: ibuf

#ifdef PROFILE
      character (len=max_name)            :: timer_label(2)
#endif

!   
! !DESCRIPTION:
!
!   This subroutine initializes the environment of the PRISM
!   coupler (PSMILe library and I/O library). It must be called
!   once initially by each process of the application. After
!   calling prism_init, all the SCC information is accessible
!   by the application.
!
!
! !SEE ALSO:
!
!   prism_init_comp, prism_initialized, prism_terminate, prism_terminated
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 01.12.03    R. Redler    created
! 09.01.03    R.Vogelsang  added call to psmile_io_init
!
!EOP
!----------------------------------------------------------------------
!
! $Id: prism_init.F90 2846 2011-01-04 12:02:30Z hanke $
! $Author: hanke $
!
  Character(len=len_cvs_string), save :: mycvs = 
      '$Id: prism_init.F90 2846 2011-01-04 12:02:30Z hanke $'
!
! ---------------------------------------------------------------------

#ifdef VERBOSE
      print *, trim(appl_name), ': prism_init: start'
#endif /* VERBOSE */
!
!------------------------------------------------------------------------
!  1st Initialization
!------------------------------------------------------------------------
!
      ierror    = 0
      intercomm = MPI_COMM_NULL

      called           = .false.

      parallel_io      = 1  ! if redirect is active we always write in parallel
                            ! otherwise the scc.xml has to offer another user choice.

!
!===> Generate initial string for PSMILe messages
!     String has format "[rank] application_name"
!
      write (ch_id(1:), '(a4,a)') '[?] ', trim(appl_name)
!
!===> Was PRISM already initialized ?
!
      if (PRISM_is_initialized) then
         ierror = PRISM_Warn_Init
         ierrp (1) = Appl%sequence_number
         call psmile_warning ( ierror, 'PRISM_Init', ierrp, 1, &
                 __FILE__, __LINE__ )
         return
      endif
!
!===> Initialize the Application Type
!
      Appl%name=trim(appl_name)
      Appl%args=""
      Appl%sequence_number=1
      Appl%stand_alone = .false.
      Appl%comm = MPI_COMM_NULL
      Appl%comm_user = MPI_COMM_NULL
      Appl%rank = -1
!
!===> Initialize the calendar
!
      PRISM_calendar_type = PRISM_UNDEFINED
!
!===> Get important constants
!
      real_pi = atan (1.0) * 4.0
      real_pi2 = 2.0 * real_pi
      real_pih = real_pi * 0.5
      real_deg2rad = real_pi / 180.0
!
      dble_pi = atan (1.0d0) * 4.0d0
      dble_pi2 = 2.0d0 * dble_pi
      dble_pih = dble_pi * 0.5d0
      dble_deg2rad = dble_pi / 180.0d0
!
! -----------------------------------------------------------------------
!  2nd MPI initialization phase
! -----------------------------------------------------------------------
!
!===> Initialize MPI environment if it was not done by the application
!
      call MPI_Initialized ( flag, ierror )

      MPI_was_initialized = .not. flag

      if (.not. flag) then

        call MPI_Init (ierror)

        if ( ierror /= MPI_SUCCESS ) then
           ierrp (1) = ierror
           call psmile_error ( PRISM_Error_MPI, 'MPI_Init', &
                               ierrp, 1, __FILE__, __LINE__ )
           return
        endif

      endif
!
!===> Initialize Fortran (MPI) datatypes
!
      call psmile_init_datatypes (ierror)
      if (ierror /= 0) return

#if ! defined ( PRISM_with_MPI1 )
!
! MPI 2 is available:
! -------------------
!
!===> Get Parent communicator in order to determine type of creation
!
! intercomm == MPI_COMM_NULL: All applications were simultaneously started
!                             by the mpirun/mpiexec command
!
! intercomm != MPI_COMM_NULL: Driver has spawned the applications
!
      call MPI_Comm_get_parent ( intercomm, ierror )

      if ( ierror /= MPI_SUCCESS ) then
         ierrp (1) = ierror
         ierror = PRISM_Error_MPI

         call psmile_error ( ierror, 'MPI_Comm_get_parent', &
                             ierrp, 1, __FILE__, __LINE__ )
         return
      endif

#endif /* not PRISM_with_MPI1 */

!
!===> Get initial data from root of coupler processes and
!     define communicators dependent on type of creation used
!
!     Determine the application execution mode, whether it is coupled or
!     running stand alone. Appl%stand_alone will be set to .true. in
!     PSMILe_Init_MPI1 it no information was received from the driver
!     concerning the number of applications.
!
      if ( intercomm == MPI_COMM_NULL ) then

         call psmile_init_mpi1 (ierror)

      else

         Appl%stand_alone = .false.
         call psmile_init_mpi2 (intercomm, ierror)

      endif

      if ( ierror /= 0 ) return

! create mpi reduce operation for double-double precision numbers
! this is used for comuting the global sum needed for conservation
! of flux
      call MPI_OP_CREATE(psmile_ddadd_mpi_callback, .TRUE., PSMILE_MPI_SUMDD, ierror)

!-----------------------------------------------------------------------
!  3rd Redirect Standard Output
!-----------------------------------------------------------------------

      output_into_file = PRISM_Redirect(1) == 1

      if ( output_into_file .and. .not. called ) then
         lenstr = len_trim(Appl%name)
#ifdef NAG_COMPILER
         call psmile_redirstdout ( Appl%name(1:lenstr), lenstr, &
                                   parallel_io,  Appl%rank, Appl%size, ierror)
!rr                                parallel_io,  global_rank, ierror)
#else
         ndibuf = lenstr / length_of_integer + 1

         Allocate (ibuf(1:ndibuf), STAT = ierror)
         if ( ierror > 0 ) then
            ierrp (1) = ierror
            ierrp (2) = ndibuf
            call psmile_error ( PRISM_Error_Alloc, 'ibuf', &
                                ierrp, 2, __FILE__, __LINE__ )
            return
         endif

         ipos = 0

         call psmile_char2buf (ibuf, ndibuf, ipos, Appl%name(1:lenstr))

         call psmile_redirstdout ( ibuf, lenstr, &
                                   parallel_io,  Appl%rank, Appl%size, ierror)
!rr                                parallel_io,  global_rank, ierror)
#endif
         called = .true.
      else if ( output_into_file .and. called ) then
         print *, trim(Appl%name), ' Skipped redirect of stdout for ', trim(Appl%name)
         print *, trim(Appl%name), ' Only one redirect per application process is possible.'
      else
         print *, trim(Appl%name), ' Skipped redirect of stdout for ', trim(Appl%name)
      endif
!
! -----------------------------------------------------------------------
!   3.5 Initialize timers
! -----------------------------------------------------------------------

#ifdef PROFILE
      timer_label(1) = 'Init  to  Finalize'
      timer_label(2) = 'Init  to  Enddef'

      call psmile_timer_init (2, timer_label, 'Application : ' // TRIM(Appl%name), &
                              TRIM(Appl%name) // '_timer_stats', Appl%comm)

      call psmile_timer_start(1)
      call psmile_timer_start(2)
#endif
!
! -----------------------------------------------------------------------
!   4th Generate string for PSMILe messages
!       String has format "[rank] application_name"
! -----------------------------------------------------------------------

      ch_id = '['
      ipos = 1
      call psmile_int2char (global_rank, ch_id, ipos)

      write (ch_id(ipos+1:), 8000) trim(appl_name)

! -----------------------------------------------------------------------
!   5th Preallocate derived types
! -----------------------------------------------------------------------
!
!===> Pre-allocate as many components as are defined in the SSC file
!     Note that an equivalent array is allocated to store smioc info
!     See psmile_smioc_init.F90
!
      Number_of_Comps_allocated = PRISM_noCompsPerAppl(Appl%sequence_number)

      Allocate (Comps(Number_of_Comps_allocated), STAT = ierror)

      if ( ierror > 0 ) then
         ierrp (1) = ierror
         ierrp (2) = Number_of_Comps_allocated
         ierror = PRISM_Error_Alloc

         call psmile_error ( ierror, 'Components', &
                             ierrp, 2, __FILE__, __LINE__ )
         return
      endif
!
!===> Store names of components. The sequence of components is directly
!     related to the global component IDs. Here we extract the component
!     name that have been specified for the current application. This
!     is important for receiving the smioc information if more than one
!     component resides on an application process, since the driver
!     sends smioc info to components in the order of the component list.
!     Receiving the smioc information in the PSMILe is based on the same
!     ordering.
!
      Comps(1:Number_of_Comps_allocated)%status = PSMILe_status_free

      comp_index = 1
      do i = 2, Appl%sequence_number
        comp_index = comp_index + PRISM_noCompsPerAppl(i-1)
      enddo
!
!===> Pre-allocate Methods
!
      Number_of_Methods_allocated = 8

      Allocate (Methods(Number_of_Methods_allocated), STAT = ierror)

      if ( ierror > 0 ) then
         ierrp (1) = ierror
         ierrp (2) = Number_of_Methods_allocated

         ierror = PRISM_Error_Alloc
         call psmile_error ( ierror, 'Methods', &
                             ierrp, 2, __FILE__, __LINE__ )
         return
      endif
!
      Methods(:)%status = PSMILe_status_free
!
      do i = 1, Number_of_Methods_allocated
         Nullify ( Methods(i)%send_infos_direct )
         Nullify ( Methods(i)%send_infos_coupler )
         Nullify ( Methods(i)%recv_infos_direct )
         Nullify ( Methods(i)%recv_infos_coupler )
         Nullify ( Methods(i)%coords_pointer )
         Nullify ( Methods(i)%subgrid_pointer )
         Nullify ( Methods(i)%vector_pointer )
         Nullify ( Methods(i)%halo_pointer )
         Nullify ( Methods(i)%gauss2_real(1)%vector)
         Nullify ( Methods(i)%gauss2_real(2)%vector)
         Nullify ( Methods(i)%gauss2_dble(1)%vector)
         Nullify ( Methods(i)%gauss2_dble(2)%vector)
#if defined ( PRISM_QUAD_TYPE )
         Nullify ( Methods(i)%gauss2_quad(1)%vector)
         Nullify ( Methods(i)%gauss2_quad(2)%vector)
#endif
      enddo
!
!===> Pre-allocate Grids
!
      Number_of_Grids_allocated = 8

      Allocate (Grids(Number_of_Grids_allocated), STAT = ierror)

      if ( ierror > 0 ) then
         ierrp (1) = ierror
         ierrp (2) = Number_of_Grids_allocated

         ierror = PRISM_Error_Alloc
         call psmile_error ( ierror, 'Grids', &
                             ierrp, 2, __FILE__, __LINE__ )
         return
      endif
!
      Grids(:)%status = PSMILe_status_free
      Grids(:)%nlev = 0
      Grids(:)%nbr_halo_segments = 0
      Grids(:)%comp_id = PSMILe_undef
!
      do i = 1, Number_of_Grids_allocated
        Nullify ( Grids(i)%corner_pointer )
        Nullify ( Grids(i)%partition )
        Nullify ( Grids(i)%extent )
        Nullify ( Grids(i)%mg_infos )
        Nullify ( Grids(i)%nbr_points_per_lat )
        Nullify ( Grids(i)%mg_infos )
        Nullify ( Grids(i)%send_list )
        Nullify ( Grids(i)%recv_list )
        Nullify ( Grids(i)%get_list )
        Nullify ( Grids(i)%put_list )
        Nullify ( Grids(i)%remote_index )
        Nullify ( Grids(i)%star )
        Nullify ( Grids(i)%face )
        Nullify ( Grids(i)%global_beg )
        Nullify ( Grids(i)%global_end )
        Nullify ( Grids(i)%l2g )
        Nullify ( Grids(i)%g2l )
        Nullify ( Grids(i)%halo )
      enddo
!
!===> Pre-allocate Masks
!
      Number_of_Masks_allocated = 8

      Allocate (Masks(Number_of_Masks_allocated), STAT = ierror)

      if ( ierror > 0 ) then
         ierrp (1) = ierror
         ierrp (2) = Number_of_Masks_allocated

         ierror = PRISM_Error_Alloc
         call psmile_error ( ierror, 'Masks', &
                             ierrp, 2, __FILE__, __LINE__ )
         return
      endif
!
      Masks(:)%status = PSMILe_status_free
!
      do i = 1, Number_of_Masks_allocated
        Nullify ( Masks(i)%mask_array )
      enddo
!
!===> Pre-allocate Grid Functions
!
      Number_of_Fields_allocated = 8

      Allocate (Fields(Number_of_Fields_allocated), STAT = ierror)

      if ( ierror > 0 ) then
         ierrp (1) = ierror
         ierrp (2) = Number_of_Fields_allocated

         ierror = PRISM_Error_Alloc
         call psmile_error ( ierror, 'Fields', &
                             ierrp, 2, __FILE__, __LINE__ )
         return
      endif
!
      Fields(:)%status    = PSMILe_status_free
      Fields(:)%smioc_loc = PRISM_Undefined
!
!     Initialize further values of field
!
      Fields(:)%used_for_coupling = .false.
!
!     Recv info's, send ifos are handled in prism_def_var
!
      Fields(:)%Taskin%n_recv_direct  = 0
      Fields(:)%Taskin%n_recv_coupler = 0
!
      Fields(:)%Taskin%n_alloc_recv_direct  = 0
      Fields(:)%Taskin%n_alloc_recv_coupler = 0
!
      do i = 1, Number_of_Fields_allocated
         Nullify ( Fields(i)%io_infos )
         Nullify ( Fields(i)%io_chan_infos )
         Nullify ( Fields(i)%io_task_lookup )

         Nullify ( Fields(i)%Taskout )
         Nullify ( Fields(i)%Taskin%recv_direct )
         Nullify ( Fields(i)%Taskin%recv_coupler )
         Nullify ( Fields(i)%Taskin%buffer_int )
         Nullify ( Fields(i)%Taskin%buffer_real )
         Nullify ( Fields(i)%Taskin%buffer_dble )
#if defined ( PRISM_QUAD_TYPE )
         Nullify ( Fields(i)%Taskin%buffer_quad )
#endif
         Nullify ( Fields(i)%Taskin%Judate_Axis )
         Nullify ( Fields(i)%Taskin%In_channel )
      enddo
!
!===>  Initialise Grid relations
!
      Number_of_Cpls_allocated = 0
      Nullify (cpl_list)
!
!===> Pre-allocate Userdef structures
!
      Number_of_Userdefs_allocated = 8

      Allocate (Userdefs(Number_of_Userdefs_allocated), STAT = ierror)

      if ( ierror > 0 ) then
         ierrp (1) = ierror
         ierrp (2) = Number_of_Userdefs_allocated

         ierror = PRISM_Error_Alloc
         call PSMILe_Error ( ierror, 'Userdefs', &
                             ierrp, 2, __FILE__, __LINE__ )
         return
      endif

      Userdefs(:)%ig_transi_side = PRISM_Undefined
      Userdefs(:)%ig_nb_links = 0
      Userdefs(:)%status    = PSMILe_status_free


      do i = 1, Number_of_Userdefs_allocated
         Nullify ( Userdefs(i)%dga_wght )
         Nullify ( Userdefs(i)%iga_igl )
         Nullify ( Userdefs(i)%real_gridless )
         Nullify ( Userdefs(i)%dble_gridless )
      enddo

! -----------------------------------------------------------------------
!   6th Generate communicators for component local communication
! -----------------------------------------------------------------------
!
      call psmile_def_mpi_compcomm (ierror)
      if ( ierror /= 0 ) return
!
! -----------------------------------------------------------------------
!   7th Get ranks and sizes of communicators
! -----------------------------------------------------------------------
!
!     Note: global_rank and  Appl%rank are determined in
!           PSMILe_Init_MPI1 and PSMILe_Init_MPI2

      call MPI_Comm_size ( comm_psmile, psmile_size, ierror )

      if ( ierror /= MPI_SUCCESS ) then
         ierrp (1) = ierror
         ierror = PRISM_Error_MPI
 
         call psmile_error ( ierror, 'MPI_Comm_size', &
                             ierrp, 1, __FILE__, __LINE__ ) 
         return
      endif 

      call MPI_Comm_rank ( comm_psmile, psmile_rank, ierror ) 

      if ( ierror /= MPI_SUCCESS ) then
         ierrp (1) = ierror
         ierror = PRISM_Error_MPI

         call psmile_error ( ierror, 'MPI_Comm_rank', &
                            ierrp, 1, __FILE__, __LINE__ )
         return
      endif

      if ( Appl%stand_alone ) then

         coupler_rank = PRISM_UNDEFINED

      else

         call MPI_Comm_rank ( comm_coupler, coupler_rank, ierror )

         if ( ierror /= MPI_SUCCESS ) then
            ierrp (1) = ierror
            ierror = PRISM_Error_MPI

            call psmile_error ( ierror, 'MPI_Comm_rank', &
                                ierrp, 1, __FILE__, __LINE__ )
            return
         endif

      endif

#ifdef DEBUGX
!
!     Give the developed a possibility to attach the process
!
      call psmile_attach (psmile_rank)
#endif
!
! -----------------------------------------------------------------------
!   8th Define datatypes 
!     (1) datatype_comp_enddef used in PRISM_Enddef ()
! -----------------------------------------------------------------------
!
      call psmile_def_datatypes (ierror)
      if ( ierror /= 0 ) return
!
! -----------------------------------------------------------------------
!   9th Diagnostics
! -----------------------------------------------------------------------
!
      if ( PRISM_outputLevel > 0 ) then

        write( * , 9990 )

        if ( MPI_was_initialized ) then
          write( * , 9980 ) 'prism_init'
        else
          write( * , 9980 ) 'application'
        endif

        write( * , 9990 )

        write( * , * ) &
        'Sequ.No.: ',Appl%sequence_number,' rank ', Appl%rank,', ',Appl%size,' proc(s).'

      endif

!-----------------------------------------------------------------------
!  10th Application name ist sent to the driver
!-----------------------------------------------------------------------

      if ( .not. Appl%Stand_alone ) then
         call MPI_Send (Appl%name, max_name, MPI_CHARACTER, &
            PRISMdrv_root, 1, comm_global, ierror)

         if (ierror /= MPI_SUCCESS) THEN
            ierrp (1) = ierror
            ierrp (2) = PRISMdrv_root
            ierrp (3) = 1
            ierror = PRISM_Error_Send

            call psmile_error (ierror, 'MPI_Send', &
                              ierrp, 3, __FILE__, __LINE__ )
            return
         endif
      endif

!-----------------------------------------------------------------------
!  11th Determine the number of components per application process
!-----------------------------------------------------------------------

      index = 0
      ipos = 0
      if  ( Appl%sequence_number > 1 ) then
         do k = 1, Appl%sequence_number-1
            do j = 1, PRISM_noCompsPerAppl(k)
               index = index + PRISM_compRankSets(ipos+j)
            enddo
            ipos = index
         enddo
      endif

      index = 1
      PRISM_noCompsPerProc = 0

      do i = 1, PRISM_noCompsPerAppl(Appl%sequence_number)
         do j = 1, PRISM_compRankSets(ipos+i)
            do k = PRISM_rankSets(ipos+index,1),PRISM_rankSets(ipos+index,2),PRISM_rankSets(ipos+index,3)
               if ( Appl%rank == k ) PRISM_noCompsPerProc = PRISM_noCompsPerProc + 1
            enddo
            index = index + 1
         enddo
      enddo

      if ( .not. Appl%Stand_alone ) then
         call MPI_Send (PRISM_noCompsPerProc, 1, MPI_INTEGER, &
            PRISMdrv_root, 1, comm_global, ierror)
   
         if (ierror /= MPI_SUCCESS) THEN
            ierrp (1) = ierror
            ierrp (2) = PRISMdrv_root
            ierrp (3) = 1
            ierror = PRISM_Error_Send

            call psmile_error (ierror, 'MPI_Send', &
                              ierrp, 3, __FILE__, __LINE__ )
            return
         endif
      endif

#ifdef DEBUG
         print *, trim(ch_id), ': prism_init: PRISM_noCompsPerProc ', PRISM_noCompsPerProc
         call psmile_flushstd()
#endif
!
! -----------------------------------------------------------------------
!   12th Initialising the I/O
! -----------------------------------------------------------------------
!
#ifdef __PSMILE_WITH_IO
     call psmile_io_init(ierror)
     if ( ierror /= 0 ) then
        ierrp (1) = ierror
        call psmile_error ( ierror, 'PSMILe_IO_Init', &
                               ierrp, 1, __FILE__, __LINE__ )
     endif

#endif

      call psmile_flushstd()
!
! -----------------------------------------------------------------------
!   13th Initialising data structures for collection of user data
! -----------------------------------------------------------------------
!
      call psmile_user_data_init()
!
! -----------------------------------------------------------------------
!    14th  Epilogue
! -----------------------------------------------------------------------
!
      PRISM_is_initialized = .true.

#ifdef DEBUG
!
! Set error handler in order to enable more output
!
#if ! defined ( PRISM_with_MPI1 )
      call MPI_Comm_set_errhandler (comm_psmile, MPI_ERRORS_RETURN, ierror)
      call MPI_Comm_set_errhandler (MPI_COMM_WORLD, MPI_ERRORS_RETURN, ierror)
#else
      call MPI_errhandler_set (comm_psmile, MPI_ERRORS_RETURN, ierror)
      call MPI_errhandler_set (MPI_COMM_WORLD, MPI_ERRORS_RETURN, ierror)
#endif
#endif

#ifdef VERBOSE
      print *, trim(ch_id), ': prism_init: eof ierror =', &
               ierror
#endif /* VERBOSE */

!
! Formats:
!
8000  format ('] ', a)
9990  format (1x, 44('-'))
9980  format (1x, '--- MPI_Init was called from ', a11, ' ---')

      end subroutine prism_init