fortran66のブログ

fortran について書きます。

TYPE 中の Generic interface

オブジェクト指向型の TYPE 中で、その TYPE に作用する副プログラム名に総称名を用いることが可能です。

実行結果

ソースコード

MODULE m_TYPE
    IMPLICIT NONE
    TYPE :: t_vector
      REAL, ALLOCATABLE :: v(:)
     CONTAINS
      PROCEDURE, PASS :: init
      PROCEDURE, PASS :: dot1
      PROCEDURE, PASS :: dot2
      GENERIC :: dot => dot1, dot2
      FINAL :: fin
    END TYPE t_vector
!---------------------------------------
  CONTAINS
!---------------------------------------
    SUBROUTINE init(this, n)
     CLASS (t_vector), INTENT(IN) :: this
     INTEGER, INTENT(IN) :: n
     ALLOCATE( this%v(n) ) 
     RETURN
    END SUBROUTINE init
!---------------------------------------
    SUBROUTINE fin(this)
     TYPE (t_vector), INTENT(IN) :: this
     IF ( ALLOCATED(this%v) ) DEALLOCATE( this%v )
     PRINT *, 'deallocated'
     RETURN
    END SUBROUTINE fin
!---------------------------------------
    SUBROUTINE dot1(this, d)
     CLASS (t_vector), INTENT(IN) :: this
     REAL(8), INTENT(OUT) :: d
     d = SQRT(SUM(this%v**2))
     RETURN
    END SUBROUTINE dot1
!---------------------------------------
    SUBROUTINE dot2(this, x)
     CLASS (t_vector), INTENT(IN) :: this
     REAL, INTENT(OUT) :: x
     x = SQRT(SUM(this%v**2))
     RETURN
    END SUBROUTINE dot2
!---------------------------------------
END MODULE m_TYPE
!=========================================
PROGRAM TYPE
    USE m_TYPE
    IMPLICIT NONE
    TYPE, EXTENDS(t_vector) :: t_2vector
     REAL, ALLOCATABLE :: u(:)
    END TYPE t_2vector
!
    TYPE(t_vector), ALLOCATABLE :: x
    TYPE(t_2vector), ALLOCATABLE :: y
    REAL :: r, s
    REAL(8) :: d
    ALLOCATE(x, y)

    CALL x%init(10)
    CALL y%init(10)

    CALL RANDOM_SEED()
    CALL RANDOM_NUMBER(x%v)
    CALL RANDOM_NUMBER(y%v)
    CALL x%dot2(r)
    PRINT *, x%v
    CALL x%dot(s)
    CALL x%dot(d)
    PRINT *, '===========>', s, d
!
    CALL y%dot(s)
    CALL y%dot(d)
    PRINT *, '===========>', s, d
!
    ALLOCATE( y%u(10) )
    y%u = x%v
    PRINT *, 'DOT_PRODUCT(y%v, y%u) ===>', DOT_PRODUCT(y%v, y%u), DOT_PRODUCT(y%v, x%v)

    DEALLOCATE( y%u )
    DEALLOCATE(x, y)
!
    STOP
END PROGRAM TYPE