fortrandll.f90

图像处理的压缩算法

!  FortranDll.f90 
!
!  FUNCTIONS/SUBROUTINES exported from FORTRANDLL.dll:



!-------------------------------------------------------------------
!-------------------------------------------------------------------
!-------------------------------------------------------------------
!-------------------------------------------------------------------
!Arguments passed by value
REAL(8) FUNCTION SUMFT(A, B)

!DEC$ ALIAS SUMFT, "SUMFT"        ! export the function as SUMFT; 
!DEC$ ATTRIBUTES DLLEXPORT:: SUMFT    ! procedures is being exported to another
										  ! application
     ! The above declaration is in place of a module definition (.def) file 
	 ! for export of symbols. 

!DEC$ ATTRIBUTES VALUE :: A     ! This argument is passed by value
!DEC$ ATTRIBUTES VALUE :: B     ! This argument is passed by value
REAL(8) A
REAL(8) B

      SUMFT  = A + B 
END


!-------------------------------------------------------------------
!-------------------------------------------------------------------
!-------------------------------------------------------------------
!-------------------------------------------------------------------
!Arguments passed by reference (default)

INTEGER(4) FUNCTION INTSUM(N, M)
!DEC$ ALIAS INTSUM, "INTSUM"        ! export the function as INTSUM; 
!DEC$ ATTRIBUTES DLLEXPORT:: INTSUM    ! procedures is being exported to another application

INTEGER N,M

	INTSUM = N+M
END

!-------------------------------------------------------------------
!-------------------------------------------------------------------
!-------------------------------------------------------------------
!-------------------------------------------------------------------
!Compute the number of days from January 1, 1900, to the given date. Calls IMSL function

INTEGER(4) FUNCTION MNDAYS(IDAY, MONTH, IYEAR)
!DEC$ ALIAS INTSUM, "MNDAYS"        ! export the function as MNDAYS
!DEC$ ATTRIBUTES DLLEXPORT:: MNDAYS    ! procedures is being exported to another application

USE NUMERICAL_LIBRARIES
INTEGER IDAY, MONTH, IYEAR

INTEGER NUM

	NUM = NDAYS(IDAY, MONTH, IYEAR)
	MNDAYS = NUM
END


!-------------------------------------------------------------------
!-------------------------------------------------------------------
!-------------------------------------------------------------------
!-------------------------------------------------------------------
!calculate the sum of the elements of the array
FUNCTION CALC_SUM(D, N)
	REAL(4) :: CALC_SUM
!DEC$ ATTRIBUTES DLLEXPORT:: CALC_SUM    ! procedures is being exported to another application

    REAL(4) D 
	DIMENSION D(N)
	INTEGER N

    CALC_SUM = SUM(D)

END FUNCTION CALC_SUM

!-------------------------------------------------------------------
!-------------------------------------------------------------------
!-------------------------------------------------------------------
!-------------------------------------------------------------------
!Call IMSL routine to compute the transpose of a matrics
SUBROUTINE  TRMAT(ROWSA, COLSA, A, B)
!DEC$ ATTRIBUTES DLLEXPORT:: TRMAT    ! procedures is being exported to another application
!Input parameters
INTEGER ROWSA, COLSA
REAL	  A
DIMENSION A(ROWSA, COLSA)

!Output parameters
REAL  B
DIMENSION B(COLSA, ROWSA) 
!Local parameters
INTEGER ROWSB, COLSB,  LDB
ROWSB = COLSA
COLSB = ROWSA

	CALL ERSET (0, 0, 0) !Set the error handling
	CALL TRNRR (ROWSA, COLSA, A, ROWSA, ROWSB, COLSB, B, ROWSB)

RETURN
END 

!-------------------------------------------------------------------
!-------------------------------------------------------------------
!-------------------------------------------------------------------
!-------------------------------------------------------------------
INTEGER FUNCTION INVERT(N,A,INVA)
!DEC$ ATTRIBUTES DLLEXPORT:: INVERT  

!Input args
  INTEGER N
  REAL A
  DIMENSION A(N,N)
  REAL INVA
  DIMENSION INVA(N,N)
  
  CALL ERSET (0, 0, 0) !Set the error handling

  ! Compute the inverse
  CALL LINRG (N, A, N, INVA, N)
  ! Return error code; 0 - OK, 2 = singular, 1 - ill-conditioned, 
  INVERT = IERCD( )

END  FUNCTION INVERT

!-------------------------------------------------------------------
!-------------------------------------------------------------------
!-------------------------------------------------------------------
!Perform polynomial regression
SUBROUTINE POLYREGR(NOBS, NCOL, X, IRSP, IND, IFRQ, IWT,  &
            IPRED, CONPCM, CONPCP, MAXDEG, ICRIT, CRIT,  &
            LOF, IPRINT, NDEG, AOV, SQSS, COEF, TLOF, CASE, NRMISS)
!DEC$ ATTRIBUTES DLLEXPORT:: POLYREGR  ! procedures is being exported to another application
!Input
INTEGER NOBS, NCOL, IRSP, IND, MAXDEG
INTEGER IFRQ, IWT, IPRED
INTEGER ICRIT, LOF, IPRINT
REAL CONPCM, CONPCP, CRIT
REAL X(NOBS, NCOL)  
!Output
INTEGER NRMISS, NDEG  
REAL   AOV(15),	SQSS(MAXDEG, 4 ), COEF(MAXDEG + 1 , 4)
REAL   TLOF (MAXDEG, 4), CASE (NOBS , 12)

CALL ERSET (0, 0, 0) !Set the error handling

!Call IMSL function
CALL RPOLY (NOBS, NCOL, X, NOBS, IRSP, IND, IFRQ, IWT,  IPRED, CONPCM, CONPCP,&
               MAXDEG, ICRIT, CRIT,  LOF, IPRINT, NDEG, AOV, SQSS, MAXDEG, COEF, &
			   MAXDEG + 1, TLOF, MAXDEG, CASE, NOBS, NRMISS)
   RETURN
END

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

  SUBROUTINE CONVOLUTE(NX, NY, X,Y, Z)
 !DEC$ ATTRIBUTES DLLEXPORT:: CONVOLUTE   
      INTEGER    NX, NY

      REAL       X(NX), Y(NY), Z(NX+NY-1 )
      INTEGER    NZ
!     Compute vector convolution
!     Z = X * Y
      NZ=NX+NY-1
	  CALL VCONR (NX, X, NY, Y, NZ, Z)

	  RETURN
END

 !JUNK JUNK JUNK

INTEGER(4) FUNCTION ARRAYSUM(NAR)
!DEC$ ALIAS ARRAYSUM, "ARRAYSUM"        ! export the function as INTSUM; without it will export as "intsum"
!DEC$ ATTRIBUTES DLLEXPORT:: ARRAYSUM    ! procedures is being exported to another application
INTEGER J
INTEGER NAR(10)
INTEGER SUM
	SUM = 0
	DO j = 1, 10, 1
        SUM = SUM + NAR(j)
    END DO

	ARRAYSUM = SUM

END


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

FUNCTION CALC_AVERAGE(D)
     REAL :: CALC_AVERAGE
!DEC$ ALIAS CALC_AVERAGE, "CALC_AVERAGE"        ! export the function as CALC_AVERAGE; without it will export as "calc_average"
!DEC$ ATTRIBUTES DLLEXPORT:: CALC_AVERAGE    ! procedures is being exported to another application

     REAL(4), INTENT(IN) :: D(:)
     CALC_AVERAGE = SUM(D) 
  END FUNCTION CALC_AVERAGE


!-------------------------------------------------------------------
!-------------------------------------------------------------------
!-------------------------------------------------------------------
FUNCTION CALC_AVERAGE1(D)
     REAL(4) :: CALC_AVERAGE
!DEC$ ALIAS CALC_AVERAGE1, "CALC_AVERAGE1"        ! export the function as CALC_AVERAGE; without it will export as "calc_average"
!DEC$ ATTRIBUTES DLLEXPORT:: CALC_AVERAGE1    ! procedures is being exported to another application

     REAL(4), POINTER :: D(:)
     CALC_AVERAGE1 = D(1)
  END FUNCTION CALC_AVERAGE1











INTEGER    NOUT

REAL       A, ABS, B, ERRABS, ERREST, ERROR, ERRREL, EXACT, EXP, F, RESULT
      INTRINSIC  ABS, EXP
      EXTERNAL   F, QDNG, UMACH
!                                 Get output unit number
      CALL UMACH (2, NOUT)
!                                 Set limits of integration
      A = 0.0
      B = 2.0
!                                 Set error tolerances
      ERRABS = 0.0
      ERRREL = 0.001
      CALL QDNG (F, A, B, ERRABS, ERRREL, RESULT, ERREST)
!                                 Print results
      EXACT = 1.0 + EXP(2.0)
      ERROR = ABS(RESULT-EXACT)
      WRITE (NOUT,99999) RESULT, EXACT, ERREST, ERROR
99999 FORMAT (' Computed =', F8.3, 13X, ' Exact =', F8.3, /, /,' Error estimate =', 1PE10.3, 6X, 'Error =', 1PE10.3)
      END
!
REAL FUNCTION F (X)
      REAL       X
      REAL       EXP
      INTRINSIC  EXP
      F = X*EXP(X)
RETURN
END

FUNCTION CALC_SUM1(D, N)
	REAL(4) :: CALC_SUM1
!DEC$ ATTRIBUTES DLLEXPORT:: CALC_SUM1    ! procedures is being exported to another application

    REAL(4) :: D(*)    !assumed size array
	INTEGER N

	INTEGER MAXPOINTS
	parameter( MAXPOINTS = 1000 )
	REAL(4) x(MAXPOINTS)

	INTEGER i

	DO i = 1, N
		x(i) = D(i)
	END DO

    CALC_SUM1 = SUM(x)
END FUNCTION CALC_SUM1