Search code examples
fortranfortran90intel-fortran

Generic procedure reference

I trying to compile a fortran module Y that contains a function and a subroutine that both calls the same subroutine X. When this module is compiled I get the following error:

array_lib.F90(70): error #8032: Generic procedure reference has two or
more specific procedure with the same type/rank/keyword signature. [MRGRNK]
        CALL mrgrnk(list,idx)
-------------^
array_lib.F90(141): error #8032: Generic procedure reference has two or
more specific procedure with the same type/rank/keyword signature. [MRGRNK]
        CALL mrgrnk(xarr,ist)

Can someone explain a bit what's going on here. I don't understand what's wrong?

I appreciate some insight on this.

Code:

MODULE array_lib
USE PARKIND1  ,ONLY : JPIM, JPIB, JPRB

IMPLICIT NONE

CONTAINS

FUNCTION infind(list,val,sort,dist)
USE m_mrgrnk
IMPLICIT NONE

! ----- INPUTS -----
REAL(KIND=JPRB), DIMENSION(:), INTENT(IN) :: list
REAL(KIND=JPRB), INTENT(IN) :: val
INTEGER, INTENT(IN), OPTIONAL :: sort

! ----- OUTPUTS -----
INTEGER(JPIM) :: infind
REAL(KIND=JPRB), INTENT(OUT), OPTIONAL :: dist

! ----- INTERNAL -----
REAL(KIND=JPRB), DIMENSION(SIZE(list)) :: lists
INTEGER(JPIM) :: nlist, result, tmp(1), sort_list
INTEGER(JPIM), DIMENSION(SIZE(list)) :: mask, idx

IF (PRESENT(sort)) THEN
    sort_list = sort
ELSE
    sort_list = 0
END IF

nlist = SIZE(list)
IF (sort_list == 1) THEN
    CALL mrgrnk(list,idx)
    lists = list(idx)
ELSE
    lists = list
END IF

IF (val >= lists(nlist)) THEN
    result = nlist
ELSE IF (val <= lists(1)) THEN
    result = 1
ELSE
    mask(:) = 0
    WHERE (lists < val) mask = 1
    tmp = MINLOC(mask,1)
    IF (ABS(lists(tmp(1)-1)-val) < ABS(lists(tmp(1))-val)) THEN
        result = tmp(1) - 1
    ELSE
        result = tmp(1)
    END IF
END IF
IF (PRESENT(dist)) dist = lists(result)-val
IF (sort_list == 1) THEN
    infind = idx(result)
ELSE
    infind = result
END IF

END FUNCTION infind

! ----------------------------------------------------------------------------
! SUBROUTINE LIN_INTERPOLATE
! ----------------------------------------------------------------------------
SUBROUTINE lin_interpolate(yarr,xarr,yyarr,xxarr,tol)
    USE m_mrgrnk
    IMPLICIT NONE

! ----- INPUTS -----
    REAL(KIND=JPRB), DIMENSION(:), INTENT(IN) :: yarr, xarr, xxarr
    REAL(KIND=JPRB), INTENT(IN) :: tol

! ----- OUTPUTS -----
    REAL(KIND=JPRB), DIMENSION(SIZE(xxarr)), INTENT(OUT) :: yyarr

! ----- INTERNAL -----
    REAL(KIND=JPRB), DIMENSION(SIZE(xarr)) :: ysort, xsort
    INTEGER(JPIM), DIMENSION(SIZE(xarr)) :: ist
    INTEGER(JPIM) :: nx, nxx, i, iloc
    REAL(KIND=JPRB) :: d, m

    nx = SIZE(xarr)
    nxx = SIZE(xxarr)

! // xsort, ysort are sorted versions of xarr, yarr
    CALL mrgrnk(xarr,ist)
    ysort = yarr(ist)
    xsort = xarr(ist)

    DO i=1,nxx
        iloc = infind(xsort,xxarr(i),dist=d)
        IF (d > tol) THEN
            PRINT *, 'interpolation error'
            STOP
        END IF
        IF (iloc == nx) THEN
        !     :: set to the last value
            yyarr(i) = ysort(nx)
        ELSE
        !     :: is there another CLOSEby value?
            IF (ABS(xxarr(i)-xsort(iloc+1)) < 2*tol) THEN
            !       :: yes, DO a linear interpolation
                m = (ysort(iloc+1)-ysort(iloc))/(xsort(iloc+1)-xsort(iloc))
                yyarr(i) = ysort(iloc) + m*(xxarr(i)-xsort(iloc))
            ELSE
            !       :: no, set to the only nearby value
                yyarr(i) = ysort(iloc)
            END IF
        END IF
    END DO

 END SUBROUTINE lin_interpolate

 END MODULE array_lib

The MODULE M_MRGRNK:

MODULE m_mrgrnk
USE PARKIND1  ,ONLY : JPIM, JPIB, JPRB

PUBLIC :: mrgrnk
!PRIVATE :: kdp
PRIVATE :: R_mrgrnk, I_mrgrnk, D_mrgrnk

INTERFACE mrgrnk
MODULE PROCEDURE D_mrgrnk, R_mrgrnk, I_mrgrnk
END INTERFACE mrgrnk

CONTAINS

SUBROUTINE D_mrgrnk (XDONT, IRNGT)
REAL(KIND=JPRB), DIMENSION (:), INTENT (IN) :: XDONT
INTEGER(KIND=JPIM), DIMENSION (:), INTENT (OUT) :: IRNGT
REAL(KIND=JPRB):: XVALA, XVALB

INTEGER(KIND=JPIM), DIMENSION (SIZE(IRNGT)) :: JWRKT
INTEGER(KIND=JPIM) :: LMTNA, LMTNC, IRNG1, IRNG2
INTEGER(KIND=JPIM) :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB

NVAL = Min (SIZE(XDONT), SIZE(IRNGT))
SELECT CASE (NVAL)
CASE (:0)
RETURN
CASE (1)
IRNGT (1) = 1
RETURN
CASE DEFAULT
CONTINUE
END SELECT

DO IIND = 2, NVAL, 2
    IF (XDONT(IIND-1) <= XDONT(IIND)) THEN
        IRNGT (IIND-1) = IIND - 1
        IRNGT (IIND) = IIND
    ELSE
        IRNGT (IIND-1) = IIND
        IRNGT (IIND) = IIND - 1
    END IF
END DO
IF (MODULO(NVAL, 2) /= 0) THEN
    IRNGT (NVAL) = NVAL
END IF

LMTNA = 2
LMTNC = 4

DO
IF (NVAL <= 2) EXIT

DO IWRKD = 0, NVAL - 1, 4
    IF ((IWRKD+4) > NVAL) THEN
        IF ((IWRKD+2) >= NVAL) EXIT

        IF (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) EXIT

        IF (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) THEN
            IRNG2 = IRNGT (IWRKD+2)
            IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
            IRNGT (IWRKD+3) = IRNG2
        ELSE
            IRNG1 = IRNGT (IWRKD+1)
            IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
            IRNGT (IWRKD+3) = IRNGT (IWRKD+2)
            IRNGT (IWRKD+2) = IRNG1
        END IF
        EXIT
    END IF
    IF (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) CYCLE
    IF (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) THEN
        IRNG2 = IRNGT (IWRKD+2)
        IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
        IF (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) THEN
            IRNGT (IWRKD+3) = IRNG2
        ELSE
            IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
            IRNGT (IWRKD+4) = IRNG2
        END IF
    ELSE
        IRNG1 = IRNGT (IWRKD+1)
        IRNG2 = IRNGT (IWRKD+2)
        IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
        IF (XDONT(IRNG1) <= XDONT(IRNGT(IWRKD+4))) THEN
            IRNGT (IWRKD+2) = IRNG1
            IF (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) THEN
                IRNGT (IWRKD+3) = IRNG2
            ELSE
                IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
                IRNGT (IWRKD+4) = IRNG2
            END IF
        ELSE
            IRNGT (IWRKD+2) = IRNGT (IWRKD+4)
            IRNGT (IWRKD+3) = IRNG1
            IRNGT (IWRKD+4) = IRNG2
        END IF
    END IF
END DO

LMTNA = 4
EXIT
END DO

DO
IF (LMTNA >= NVAL) EXIT
IWRKF = 0
LMTNC = 2 * LMTNC

DO
IWRK = IWRKF
IWRKD = IWRKF + 1
JINDA = IWRKF + LMTNA
IWRKF = IWRKF + LMTNC
IF (IWRKF >= NVAL) THEN
    IF (JINDA >= NVAL) EXIT
    IWRKF = NVAL
END IF
IINDA = 1
IINDB = JINDA + 1

JWRKT (1:LMTNA) = IRNGT (IWRKD:JINDA)

XVALA = XDONT (JWRKT(IINDA))
XVALB = XDONT (IRNGT(IINDB))

DO
IWRK = IWRK + 1

IF (XVALA > XVALB) THEN
    IRNGT (IWRK) = IRNGT (IINDB)
    IINDB = IINDB + 1
    IF (IINDB > IWRKF) THEN
    !  Only A still with unprocessed values
        IRNGT (IWRK+1:IWRKF) = JWRKT (IINDA:LMTNA)
        EXIT
    END IF
    XVALB = XDONT (IRNGT(IINDB))
ELSE
    IRNGT (IWRK) = JWRKT (IINDA)
    IINDA = IINDA + 1
    IF (IINDA > LMTNA) EXIT! Only B still with unprocessed values
    XVALA = XDONT (JWRKT(IINDA))
END IF

END DO
END DO
LMTNA = 2 * LMTNA
END DO

RETURN

END SUBROUTINE D_mrgrnk

SUBROUTINE R_mrgrnk (XDONT, IRNGT)
REAL(KIND=JPRB), DIMENSION (:), INTENT (IN) :: XDONT
INTEGER(KIND=JPIM), DIMENSION (:), INTENT (OUT) :: IRNGT
REAL(KIND=JPRB) :: XVALA, XVALB

INTEGER(KIND=JPIM), DIMENSION (SIZE(IRNGT)) :: JWRKT
INTEGER(KIND=JPIM) :: LMTNA, LMTNC, IRNG1, IRNG2
INTEGER(KIND=JPIM) :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB

NVAL = Min (SIZE(XDONT), SIZE(IRNGT))
SELECT CASE (NVAL)
CASE (:0)
RETURN
CASE (1)
IRNGT (1) = 1
RETURN
CASE DEFAULT
CONTINUE
END SELECT

DO IIND = 2, NVAL, 2
    IF (XDONT(IIND-1) <= XDONT(IIND)) THEN
        IRNGT (IIND-1) = IIND - 1
        IRNGT (IIND) = IIND
    ELSE
        IRNGT (IIND-1) = IIND
        IRNGT (IIND) = IIND - 1
    END IF
END DO
IF (MODULO(NVAL, 2) /= 0) THEN
    IRNGT (NVAL) = NVAL
END IF
LMTNA = 2
LMTNC = 4
DO
IF (NVAL <= 2) EXIT
DO IWRKD = 0, NVAL - 1, 4
    IF ((IWRKD+4) > NVAL) THEN
        IF ((IWRKD+2) >= NVAL) EXIT
        IF (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) EXIT
        IF (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) THEN
            IRNG2 = IRNGT (IWRKD+2)
            IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
            IRNGT (IWRKD+3) = IRNG2
        ELSE
            IRNG1 = IRNGT (IWRKD+1)
            IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
            IRNGT (IWRKD+3) = IRNGT (IWRKD+2)
            IRNGT (IWRKD+2) = IRNG1
        END IF
        EXIT
    END IF
    IF (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Cycle
    IF (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) THEN
        IRNG2 = IRNGT (IWRKD+2)
        IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
        IF (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) THEN
        !   1 3 2 4
            IRNGT (IWRKD+3) = IRNG2
        ELSE
        !   1 3 4 2
            IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
            IRNGT (IWRKD+4) = IRNG2
        END IF
    ELSE
Solution

  • There issues here is :

    • The specific interfaces with your generic interface must be unique (type/rank/etc must not be identical).

    Specifically, what is happening is that your module procedures do not appear distinct, so when you:

    CALL mrgrnk(xarr,ist)

    the compiler cannot determine which specific module procedure to invoke.

    Your generic interface is

    INTERFACE mrgrnk
  MODULE PROCEDURE D_mrgrnk, R_mrgrnk, I_mrgrnk
END INTERFACE mrgrnk

    and your specific interfaces are

    SUBROUTINE D_mrgrnk (XDONT, IRNGT)
   REAL(KIND=JPRB), DIMENSION (:), INTENT (IN) :: XDONT
   INTEGER(KIND=JPIM), DIMENSION (:), INTENT (OUT) :: IRNGT
END SUBROUTINE

SUBROUTINE R_mrgrnk (XDONT, IRNGT)
   REAL(KIND=JPRB), DIMENSION (:), INTENT (IN) :: XDONT
   INTEGER(KIND=JPIM), DIMENSION (:), INTENT (OUT) :: IRNGT
END SUBROUTINE

SUBROUTINE I_mrgrnk (XDONT, IRNGT)
  INTEGER(KIND=JPIM), DIMENSION (:), INTENT (IN)  :: XDONT
  INTEGER(KIND=JPIM), DIMENSION (:), INTENT (OUT) :: IRNGT
END SUBROUTINE

    As you can see the interfaces to D__mrgrnk and R_mrgrnk are the same and when you call mrgrnk with arguments of type REAL(KIND=JPRB) and INTEGER(KIND=JPIM), the compiler cannot determine which procedure to call. In order to fix this, you need to differentiate the types of the arguments to D__mrgrnk and R_mrgrnk and based upon their naming, the way you probably want to do this is to make D__mrgrnk take a real type that is double precision while R_mrgrnk takes a real that is single precision.