pdispg

Fortran source

0001 C
0002 C pdispg.f - Gateway function for pdisp.f
0003 C
0004 C This is the FORTRAN code required for interfacing pdisp to MATLAB.
0005 C
0006 C This subroutine is the main gateway to MATLAB.  When the pdisp MEX function
0007 C  is executed MATLAB calls the MEXFUNCTION subroutine in the corresponding
0008 C  MEX file.
0009 C
0010 C J. Decker 10/26/05
0011 C
0012       SUBROUTINE MEXFUNCTION(NLHS, PLHS, NRHS, PRHS)
0013 C
0014 C-----------------------------------------------------------------------
0015 C     (pointer) Replace integer by integer*8 on the DEC Alpha
0016 C     64-bit platform
0017 C
0018       INTEGER PLHS(*), PRHS(*)
0019 C
0020 C-----------------------------------------------------------------------
0021 C
0022       INTEGER NLHS, NRHS
0023 C
0024 C-----------------------------------------------------------------------
0025 C     (pointer) Replace integer by integer*8 on the DEC Alpha
0026 C     64-bit platform
0027 C
0028       INTEGER MXCREATEDOUBLEMATRIX, MXGETPR
0029 C
0030 C-----------------------------------------------------------------------
0031 C
0032 C
0033       INTEGER MXGETM, MXGETN
0034 C
0035 C KEEP THE ABOVE SUBROUTINE, ARGUMENT, AND FUNCTION DECLARATIONS FOR USE
0036 C IN ALL YOUR FORTRAN MEX FILES.
0037 C---------------------------------------------------------------------
0038 C
0039 C-----------------------------------------------------------------------
0040 C     (pointer) Replace integer by integer*8 on the DEC Alpha
0041 C     64-bit platform
0042 C
0043       INTEGER rnarp,cargrp,cargip,zrp,zip
0044 C
0045       INTEGER N1,N2
0046       INTEGER M1,M2,M3
0047 C
0048       PARAMETER (N1 = 1001)
0049       PARAMETER (N2 = 1001)
0050 C      
0051       PARAMETER (M1 = 1)
0052       PARAMETER (M2 = 1001)
0053       PARAMETER (M3 = 1001)
0054 C
0055       real*8 rnar(M1),cargr(M2),cargi(M3)
0056       real*8 zr(N1),zi(N2)
0057 C
0058 C CHECK FOR PROPER NUMBER OF ARGUMENTS
0059 C
0060       IF (NRHS .NE. 3) THEN
0061         CALL MEXERRMSGTXT('R2D2 requires 3 input arguments')
0062       ENDIF  
0063       IF (NLHS .GT. 2) THEN
0064         CALL MEXERRMSGTXT('R2D2 requires 2 output argument')
0065       ENDIF
0066 C
0067 C CHECK THE DIMENSIONS OF INPUTS.
0068 C
0069       IF (M1 .NE. MXGETN(PRHS(1))) THEN
0070         CALL MEXERRMSGTXT('wrong size for arg 1')
0071       ENDIF
0072 C
0073       IF (M2 .NE. MXGETN(PRHS(2))) THEN
0074         CALL MEXERRMSGTXT('wrong size for arg 2')
0075       ENDIF
0076 C
0077       IF (M3 .NE. MXGETN(PRHS(3))) THEN
0078         CALL MEXERRMSGTXT('wrong size for arg 3')
0079       ENDIF
0080 C
0081 C CREATE A MATRIX FOR RETURN ARGUMENT
0082 C
0083       PLHS(1) = MXCREATEDOUBLEMATRIX(1,N1,0)
0084       PLHS(2) = MXCREATEDOUBLEMATRIX(1,N2,0)
0085 C
0086 C ASSIGN POINTERS TO THE VARIOUS PARAMETERS
0087 C
0088       zrp = MXGETPR(PLHS(1))
0089       zip = MXGETPR(PLHS(2))
0090 C
0091       rnarp = MXGETPR(PRHS(1))
0092       cargrp = MXGETPR(PRHS(2))
0093       cargip = MXGETPR(PRHS(3))
0094 C
0095 C COPY RIGHT HAND ARGUMENTS TO LOCAL ARRAYS OR VARIABLES
0096 C
0097       CALL MXCOPYPTRTOREAL8(rnarp, rnar, M1)
0098       CALL MXCOPYPTRTOREAL8(cargrp, cargr, M2)
0099       CALL MXCOPYPTRTOREAL8(cargip, cargi, M3)
0100 C
0101 C DO THE ACTUAL COMPUTATIONS IN A SUBROUTINE
0102 C       CREATED ARRAYS.
0103 C
0104       CALL pdisp(rnar,cargr,cargi,zr,zi)
0105 C
0106 C COPY OUTPUT WHICH IS STORED IN LOCAL ARRAY TO MATRIX OUTPUT
0107       CALL MXCOPYREAL8TOPTR(zr, zrp, N1)
0108       CALL MXCOPYREAL8TOPTR(zi, zip, N2)
0109 C
0110       RETURN
0111       END