psmile_print_method_info.F90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright 2006-2010, NEC Europe Ltd., London, UK.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!BOP
!
! !ROUTINE: PSMILe_Print_method_info
!
! !INTERFACE:

      subroutine psmile_print_method_info (method_id)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_Print_method_info
!
      implicit none
!
! !INPUT PARAMETERS:
!
      integer,Intent(In)  :: method_id

!     Handle to the method information to be printed.
!
! !LOCAL VARIABLES
!
     character(len=22), save :: name_status (PSMILe_Status_free: 
                                             PSMILe_Status_commited)
!    character(len=17), save :: name_grid   (PSMILe_Grid_Block: &
!                                            PSMILe_Grid_Block)

     character(len=24), save :: name_method (PSMILe_PointMethod: 
                                             PSMILe_SubgridMethod)

     Type (Coords_Block), Pointer  :: coords_pointer
     Type (Subgrid_Block), Pointer :: subgrid_pointer

     data name_status /'PSMILe_Status_free', 'PSMILe_status_defined', &
                       'PSMILe_Status_commited'/
!    data name_grid   /'PSMILe_Grid_Block'/

     data name_method /'PSMILe_PointMethod', 'PSMILe_VectorPointMethod', &
                       'PSMILe_SubgridMethod'/
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Print_method_info" prints the info of a method handle.
!
!
! !REVISION HISTORY:
!
!   Date      Programmer    Description
! ----------  -----------   -----------
! 01.12.03    H. Ritzdorf   created
!
!EOP
!----------------------------------------------------------------------
!
! $Id: psmile_print_method_info.F90 2687 2010-10-28 15:15:52Z coquart $
! $Author: coquart $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_print_method_info.F90 2687 2010-10-28 15:15:52Z coquart $'
!
!----------------------------------------------------------------------
!
      write (*, 9000) trim(ch_id), method_id
!
!  Check
!
      if (method_id > Number_of_Methods_allocated .or. &
          method_id < 1) then

         write (*, 9010) 'Is an invalid method id'

         call psmile_flushstd ()
         return
      endif
!
      if (Methods(method_id)%status == PSMILe_status_free) then
         write (*, 9010) 'Is currently free'

         call psmile_flushstd ()
         return
      endif
!
      if (Methods(method_id)%status >= PSMILe_Status_free .and. &
          Methods(method_id)%status <= PSMILe_status_commited) then
          write (*, 9020) 'status             ', Methods(method_id)%status, &
                          name_status (Methods(method_id)%status)
      else
          write (*, 9020) 'status             ', Methods(method_id)%status
      endif
!
!  Print general info
!
      write (*, 9020) 'grid_id                ', Methods(method_id)%grid_id
      write (*, 9020) 'method type            ', Methods(method_id)%method_type, &
                                                 name_method(Methods(method_id)%method_type)
      write (*, 9020) 'size                   ', Methods(method_id)%size
      write (*, 9020) 'previous method in grid', Methods(method_id)%previous_method_in_grid
      write (*, 9020) 'next method in grid    ', Methods(method_id)%next_method_in_grid

      if (Methods(method_id)%used_for_coupling) then
         write (*, 9030) 'used_for_coupling     ', 'true'
      else
         write (*, 9030) 'used_for_coupling     ', 'false'
      endif

!-----------------------------------------------------------------------
!
!  Print info concerning method blocks
!
!-----------------------------------------------------------------------

      if ( Associated(Methods(method_id)%coords_pointer) ) then

      Nullify ( coords_pointer )
      coords_pointer  => Methods(method_id)%coords_pointer

      if (Associated(coords_pointer%coords_real(1)%vector)) then
         write (*, 9030) 'coords_real(1)%vector pointer', 'is associated'
      else
         write (*, 9030) 'coords_real(1)%vector pointer', 'is not associated'
      endif

      if (Associated(coords_pointer%coords_real(2)%vector)) then
         write (*, 9030) 'coords_real(2)%vector pointer', 'is associated'
      else
         write (*, 9030) 'coords_real(2)%vector pointer', 'is not associated'
      endif

      if (Associated(coords_pointer%coords_real(3)%vector)) then
         write (*, 9030) 'coords_real(3)%vector pointer', 'is associated'
      else
         write (*, 9030) 'coords_real(3)%vector pointer', 'is not associated'
      endif

      if (Associated(coords_pointer%coords_dble(1)%vector)) then
         write (*, 9030) 'coords_dble(1)%vector pointer', 'is associated'
      else
         write (*, 9030) 'coords_dble(1)%vector pointer', 'is not associated'
      endif

      if (Associated(coords_pointer%coords_dble(2)%vector)) then
         write (*, 9030) 'coords_dble(2)%vector pointer', 'is associated'
      else
         write (*, 9030) 'coords_dble(2)%vector pointer', 'is not associated'
      endif

      if (Associated(coords_pointer%coords_dble(3)%vector)) then
         write (*, 9030) 'coords_dble(3)%vector pointer', 'is associated'
      else
        write (*, 9030) 'coords_dble(3)%vector pointer', 'is not associated'
      endif

      else

            write (*, 9030) 'No coordinate pointer ', 'is associated'

      endif

!-----------------------------------------------------------------------

      if ( Associated(Methods(method_id)%vector_pointer) ) then

            write (*, 9030) '   vector pointer     ', 'is associated'

      else

            write (*, 9030) 'No vector pointer     ', 'is associated'

      endif

!-----------------------------------------------------------------------

      if ( Associated(Methods(method_id)%subgrid_pointer) ) then

         Nullify ( subgrid_pointer )
         subgrid_pointer  => Methods(method_id)%subgrid_pointer

         if (Associated(subgrid_pointer%subgrid_real)) then
            write (*, 9030) 'subgrid_real pointer', 'is associated'
         else
            write (*, 9030) 'subgrid_real pointer', 'is not associated'
         endif

         if (Associated(subgrid_pointer%subgrid_double)) then
            write (*, 9030) 'subgrid_double pointer', 'is associated'
         else
            write (*, 9030) 'subgrid_double pointer', 'is not associated'
         endif

      else

            write (*, 9030) 'No subgrid pointer    ', 'is associated'

      endif

!-----------------------------------------------------------------------


!
!  FLush output
!
      write (*, 9010)

      call psmile_flushstd ()
!
!-----------------------------------------------------------------------
!  Formats
!-----------------------------------------------------------------------
!
9000  format (/1x, a, ': Info on method handle', i3, ':', &
              /1x, 40('-'))
9010  format (1x, a)
9020  format (1x, a30, ' = ', i7, : 1x, a)
9030  format (1x, a30, 3x,    a)
!
      end subroutine PSMILe_Print_method_info