utilities.f90

Go to the documentation of this file.

! *********************************************************************
! * Rocstar Simulation Suite                                          *
! * Copyright@2015, Illinois Rocstar LLC. All rights reserved.        *
! *                                                                   *
! * Illinois Rocstar LLC                                              *
! * Champaign, IL                                                     *
! * www.illinoisrocstar.com                                           *
! * sales@illinoisrocstar.com                                         *
! *                                                                   *
! * License: See LICENSE file in top level of distribution package or *
! * http://opensource.org/licenses/NCSA                               *
! *********************************************************************
! *********************************************************************
! * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,   *
! * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES   *
! * OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND          *
! * NONINFRINGEMENT.  IN NO EVENT SHALL THE CONTRIBUTORS OR           *
! * COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER       *
! * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,   *
! * Arising FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE    *
! * USE OR OTHER DEALINGS WITH THE SOFTWARE.                          *
! *********************************************************************
      SUBROUTINE com_set_true( i)
        LOGICAL i
        i = .true.
      END SUBROUTINE com_set_true

      SUBROUTINE com_set_false( i)
        LOGICAL i
        i = .false.
      END SUBROUTINE com_set_false

      SUBROUTINE com_copy_string( str_frm, len_frm, str_to, len_to)
        INTEGER, INTENT(IN) :: len_frm, len_to

        CHARACTER( len_frm), INTENT(IN) :: str_frm
        CHARACTER( len_to), INTENT(OUT) :: str_to

        str_to = str_frm
      END SUBROUTINE com_copy_string

      SUBROUTINE com_mapptr_chr1d( p, tonull, x, n) 
        IMPLICIT NONE

        CHARACTER, POINTER :: p(:)
        INTEGER, INTENT(IN) :: tonull
        INTEGER, INTENT(IN) :: n
        CHARACTER, TARGET :: x(n)

        IF ( tonull /= 0) THEN
           nullify( p)
        ELSE
           p => x
        END IF

      END SUBROUTINE com_mapptr_chr1d

      SUBROUTINE com_mapptr_int0d( p, tonull, x) 

        IMPLICIT NONE

        INTEGER, POINTER :: p
        INTEGER, INTENT(IN) :: tonull
        INTEGER, TARGET :: x

        IF ( tonull /= 0) THEN
           nullify( p)
        ELSE
           p => x
        END IF

      END SUBROUTINE com_mapptr_int0d

      SUBROUTINE com_mapptr_int1d( p, tonull, x, n) 

        IMPLICIT NONE

        INTEGER, POINTER :: p(:)
        INTEGER, INTENT(IN) :: tonull
        INTEGER, INTENT(IN) :: n
        INTEGER, TARGET :: x(n)

        IF ( tonull /= 0) THEN
           nullify( p)
        ELSE
           p => x
        END IF

      END SUBROUTINE com_mapptr_int1d

      SUBROUTINE com_mapptr_int2d( p, tonull, x, n1, n2)

        IMPLICIT NONE

        INTEGER, POINTER :: p(:, :)
        INTEGER, INTENT(IN) :: tonull
        INTEGER, INTENT(IN) :: n1, n2
        INTEGER, TARGET :: x(n1, n2)

        IF ( tonull /= 0) THEN
           nullify( p)
        ELSE
           p => x
        END IF

      END SUBROUTINE com_mapptr_int2d

      SUBROUTINE com_mapptr_int3d( p, tonull, x, n1, n2, n3)

        IMPLICIT NONE

        INTEGER, POINTER :: p(:, :, :)
        INTEGER, INTENT(IN) :: tonull
        INTEGER, INTENT(IN) :: n1, n2, n3
        INTEGER, TARGET :: x(n1, n2, n3)

        IF ( tonull /= 0) THEN
           nullify( p)
        ELSE
           p => x
        END IF

      END SUBROUTINE com_mapptr_int3d


      SUBROUTINE com_mapptr_flt0d( p, tonull, x) 

        IMPLICIT NONE

        INTERFACE
           SUBROUTINE com_map_cptr_flt( x, y)
             REAL, INTENT(INOUT) :: x, y
           END SUBROUTINE com_map_cptr_flt
        END INTERFACE

        REAL, POINTER :: p
        INTEGER, INTENT(IN) :: tonull
        REAL, TARGET :: x

        IF ( tonull /= 0) THEN
           nullify( p)
        ELSE
           p => x
        END IF

      END SUBROUTINE com_mapptr_flt0d

      SUBROUTINE com_mapptr_flt1d( p, tonull, x, n) 

        IMPLICIT NONE

        REAL, POINTER :: p(:)
        INTEGER, INTENT(IN) :: tonull
        INTEGER, INTENT(IN) :: n
        REAL, TARGET :: x(n)

        IF ( tonull /= 0) THEN
           nullify( p)
        ELSE
           p => x
        END IF

      END SUBROUTINE com_mapptr_flt1d

      SUBROUTINE com_mapptr_flt2d( p, tonull, x, n1, n2)

        IMPLICIT NONE

        REAL, POINTER :: p(:, :)
        INTEGER, INTENT(IN) :: tonull
        INTEGER, INTENT(IN) :: n1, n2
        REAL, TARGET :: x(n1, n2)

        IF ( tonull /= 0) THEN
           nullify( p)
        ELSE
           p => x
        END IF

      END SUBROUTINE com_mapptr_flt2d

      SUBROUTINE com_mapptr_flt3d( p, tonull, x, n1, n2, n3)

        IMPLICIT NONE

        REAL, POINTER :: p(:, :, :)
        INTEGER, INTENT(IN) :: tonull
        INTEGER, INTENT(IN) :: n1, n2, n3
        REAL, TARGET :: x(n1, n2, n3)

        IF ( tonull /= 0) THEN
           nullify( p)
        ELSE
           p => x
        END IF

      END SUBROUTINE com_mapptr_flt3d


      SUBROUTINE com_mapptr_dbl0d( p, tonull, x) 

        IMPLICIT NONE

        INTERFACE
           SUBROUTINE com_map_cptr_dbl( x, y)
             DOUBLE PRECISION, INTENT(INOUT) :: x, y
           END SUBROUTINE com_map_cptr_dbl
        END INTERFACE

        DOUBLE PRECISION, POINTER :: p
        INTEGER, INTENT(IN) :: tonull
        DOUBLE PRECISION, TARGET :: x

        IF ( tonull /= 0) THEN
           nullify( p)
        ELSE
           p => x
        END IF

      END SUBROUTINE com_mapptr_dbl0d

      SUBROUTINE com_mapptr_dbl1d( p, tonull, x, n) 

        IMPLICIT NONE

        DOUBLE PRECISION, POINTER :: p(:)
        INTEGER, INTENT(IN) :: tonull
        INTEGER, INTENT(IN) :: n
        DOUBLE PRECISION, TARGET :: x(n)

        IF ( tonull /= 0) THEN
           nullify( p)
        ELSE
           p => x
        END IF

      END SUBROUTINE com_mapptr_dbl1d

      SUBROUTINE com_mapptr_dbl2d( p, tonull, x, n1, n2)

        IMPLICIT NONE

        DOUBLE PRECISION, POINTER :: p(:, :)
        INTEGER, INTENT(IN) :: tonull
        INTEGER, INTENT(IN) :: n1, n2
        DOUBLE PRECISION, TARGET :: x(n1, n2)

        IF ( tonull /= 0) THEN
           nullify( p)
        ELSE
           p => x
        END IF

      END SUBROUTINE com_mapptr_dbl2d

      SUBROUTINE com_mapptr_dbl3d( p, tonull, x, n1, n2, n3)

        IMPLICIT NONE

        DOUBLE PRECISION, POINTER :: p(:, :, :)
        INTEGER, INTENT(IN) :: tonull
        INTEGER, INTENT(IN) :: n1, n2, n3
        DOUBLE PRECISION, TARGET :: x(n1, n2, n3)

        IF ( tonull /= 0) THEN
           nullify( p)
        ELSE
           p => x
        END IF

      END SUBROUTINE com_mapptr_dbl3d

      SUBROUTINE com_getptr_chr0d( p, x) 
        IMPLICIT NONE

        INTERFACE
           SUBROUTINE com_map_cptr_chr( x, y)
             CHARACTER, INTENT(INOUT) :: x, y
           END SUBROUTINE com_map_cptr_chr
        END INTERFACE

        CHARACTER, POINTER :: p
        CHARACTER, TARGET :: x

        IF ( .NOT. ASSOCIATED( p)) THEN
           CALL com_map_cptr_chr( x, x)
        ELSE
           CALL com_map_cptr_chr( p, x)
        END IF

      END SUBROUTINE com_getptr_chr0d

      SUBROUTINE com_getptr_chr1d( p, x) 
        IMPLICIT NONE

        CHARACTER, POINTER :: p(:)
        CHARACTER, TARGET :: x

        IF ( .NOT. ASSOCIATED( p)) THEN
           CALL com_map_cptr( x, x)
        ELSE
           CALL com_map_cptr( p(lbound(p,1)), x)
        END IF

      END SUBROUTINE com_getptr_chr1d

      SUBROUTINE com_getptr_int0d( p, x) 
        IMPLICIT NONE

        INTERFACE
           SUBROUTINE com_map_cptr_int( x, y)
             INTEGER, INTENT(INOUT) :: x, y
           END SUBROUTINE com_map_cptr_int
        END INTERFACE

        INTEGER, POINTER :: p
        INTEGER, TARGET :: x

        IF ( .NOT. ASSOCIATED( p)) THEN
           CALL com_map_cptr_int( x, x)
        ELSE
           CALL com_map_cptr_int( p, x)
        END IF

      END SUBROUTINE com_getptr_int0d

      SUBROUTINE com_getptr_int1d( p, x) 
        IMPLICIT NONE

        INTEGER, POINTER :: p(:)
        INTEGER, TARGET :: x

        IF ( .NOT. ASSOCIATED( p)) THEN
           CALL com_map_cptr( x, x)
        ELSE
           CALL com_map_cptr( p(lbound(p,1)), x)
        END IF

      END SUBROUTINE com_getptr_int1d

      SUBROUTINE com_getptr_int2d( p, x) 
        IMPLICIT NONE

        INTEGER, POINTER :: p(:,:)
        INTEGER, TARGET :: x

        IF ( .NOT. ASSOCIATED( p)) THEN
           CALL com_map_cptr( x, x)
        ELSE
           CALL com_map_cptr( p(lbound(p,1),lbound(p,2)), x)
        END IF

      END SUBROUTINE com_getptr_int2d
      
      SUBROUTINE com_getptr_int3d( p, x) 
        IMPLICIT NONE

        INTEGER, POINTER :: p(:,:,:)
        INTEGER, TARGET :: x

        IF ( .NOT. ASSOCIATED( p)) THEN
           CALL com_map_cptr( x, x)
        ELSE
           CALL com_map_cptr( p(lbound(p,1),lbound(p,2),lbound(p,3)), x)
        END IF

      END SUBROUTINE com_getptr_int3d
      
      SUBROUTINE com_getptr_flt0d( p, x) 
        IMPLICIT NONE

        REAL, POINTER :: p
        REAL, TARGET :: x

        IF ( .NOT. ASSOCIATED( p)) THEN
           CALL com_map_cptr_flt( x, x)
        ELSE
           CALL com_map_cptr_flt( p, x)
        END IF

      END SUBROUTINE com_getptr_flt0d

      SUBROUTINE com_getptr_flt1d( p, x) 
        IMPLICIT NONE

        REAL, POINTER :: p(:)
        REAL, TARGET :: x

        IF ( .NOT. ASSOCIATED( p)) THEN
           CALL com_map_cptr( x, x)
        ELSE
           CALL com_map_cptr( p(lbound(p,1)), x)
        END IF

      END SUBROUTINE com_getptr_flt1d

      SUBROUTINE com_getptr_flt2d( p, x) 
        IMPLICIT NONE

        REAL, POINTER :: p(:,:)
        REAL, TARGET :: x

        IF ( .NOT. ASSOCIATED( p)) THEN
           CALL com_map_cptr( x, x)
        ELSE
           CALL com_map_cptr( p(lbound(p,1),lbound(p,2)), x)
        END IF

      END SUBROUTINE com_getptr_flt2d
      
      SUBROUTINE com_getptr_flt3d( p, x) 
        IMPLICIT NONE

        REAL, POINTER :: p(:,:,:)
        REAL, TARGET :: x

        IF ( .NOT. ASSOCIATED( p)) THEN
           CALL com_map_cptr( x, x)
        ELSE
           CALL com_map_cptr( p(lbound(p,1),lbound(p,2),lbound(p,3)), x)
        END IF

      END SUBROUTINE com_getptr_flt3d
      
      SUBROUTINE com_getptr_dbl0d( p, x) 
        IMPLICIT NONE

        DOUBLE PRECISION, POINTER :: p
        DOUBLE PRECISION, TARGET :: x

        IF ( .NOT. ASSOCIATED( p)) THEN
           CALL com_map_cptr_dbl( x, x)
        ELSE
           CALL com_map_cptr_dbl( p, x)
        END IF

      END SUBROUTINE com_getptr_dbl0d

      SUBROUTINE com_getptr_dbl1d( p, x) 
        IMPLICIT NONE

        DOUBLE PRECISION, POINTER :: p(:)
        DOUBLE PRECISION, TARGET :: x

        IF ( .NOT. ASSOCIATED( p)) THEN
           CALL com_map_cptr( x, x)
        ELSE
           CALL com_map_cptr( p(lbound(p,1)), x)
        END IF

      END SUBROUTINE com_getptr_dbl1d

      SUBROUTINE com_getptr_dbl2d( p, x) 
        IMPLICIT NONE

        DOUBLE PRECISION, POINTER :: p(:,:)
        DOUBLE PRECISION, TARGET :: x

        IF ( .NOT. ASSOCIATED( p)) THEN
           CALL com_map_cptr( x, x)
        ELSE
           CALL com_map_cptr( p(lbound(p,1),lbound(p,2)), x)
        END IF

      END SUBROUTINE com_getptr_dbl2d
      
      SUBROUTINE com_getptr_dbl3d( p, x) 
        IMPLICIT NONE

        DOUBLE PRECISION, POINTER :: p(:,:,:)
        DOUBLE PRECISION, TARGET :: x

        IF ( .NOT. ASSOCIATED( p)) THEN
           CALL com_map_cptr( x, x)
        ELSE
           CALL com_map_cptr( p(lbound(p,1),lbound(p,2),lbound(p,3)), x)
        END IF

      END SUBROUTINE com_getptr_dbl3d
      
      SUBROUTINE com_settypeinfo(wrapper)
        USE m_pointers
        IMPLICIT NONE

        TYPE(data_wrapper), INTENT(OUT) :: wrapper
        TYPE(data), ALLOCATABLE, TARGET :: dat(:)
        INTEGER, ALLOCATABLE, TARGET :: a(:)
        INTEGER :: i
        
        ALLOCATE(a(10))
        ALLOCATE(dat(1))
        wrapper%p_data => dat(1)
        wrapper%p_data%a => a
        wrapper%ibegin        = 333331
        wrapper%iend          = 333332
        wrapper%p_data%ibegin = 333333
        wrapper%p_data%iend   = 333334
        
        DO i = 1, 10
           a(i) = i
        END DO

        DEALLOCATE(a)
        DEALLOCATE(dat)
        
      END SUBROUTINE com_settypeinfo

      SUBROUTINE com_chkptr_begin
        IMPLICIT NONE
        CHARACTER(17)    :: str1
        CHARACTER(33)    :: str2
        INTEGER, POINTER :: ptr1(:)
        REAL, POINTER    :: ptr2(:)

        INTERFACE
           SUBROUTINE com_chkptr_c( stage, str1, ptr1, str2, ptr2)
             CHARACTER(17), INTENT(IN) :: str1
             CHARACTER(33), INTENT(IN) :: str2
             INTEGER, POINTER          :: ptr1(:)
             REAL, POINTER             :: ptr2(:)
             INTEGER, INTENT(IN)       :: stage
           END SUBROUTINE com_chkptr_c
        END INTERFACE

        ALLOCATE (ptr1(4))
        ALLOCATE (ptr2(3))
        CALL com_chkptr_c( 1, str1, ptr1, str2, ptr2)
      END SUBROUTINE com_chkptr_begin

      SUBROUTINE com_chkptr_end( str1, ptr1, str2, ptr2)
        IMPLICIT NONE
        CHARACTER(17), INTENT(IN) :: str1
        CHARACTER(33), INTENT(IN) :: str2
        INTEGER, POINTER          :: ptr1(:)
        REAL, POINTER             :: ptr2(:)

        INTERFACE
           SUBROUTINE com_chkptr_c( stage, str2, ptr2, str1, ptr1)
             CHARACTER(17), INTENT(IN) :: str1
             CHARACTER(33), INTENT(IN) :: str2
             INTEGER, POINTER          :: ptr1(:)
             REAL, POINTER             :: ptr2(:)
             INTEGER, INTENT(IN)       :: stage
           END SUBROUTINE com_chkptr_c
        END INTERFACE

        DEALLOCATE (ptr1)
        DEALLOCATE (ptr2)

        CALL com_chkptr_c( 2, str2, ptr2, str1, ptr1)
      END SUBROUTINE com_chkptr_end