erfcc_mex_jd

Fortran source

0001 C
0002 C erfcc_mex_jd.f - Gateway function for erfcc.f
0003 C
0004 C This is the FORTRAN code required for interfacing erfcc 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 #include "fintrf.h"
0013       SUBROUTINE MEXFUNCTION(NLHS, PLHS, NRHS, PRHS)
0014 C
0015 C-----------------------------------------------------------------------
0016 C     (pointer) Replace integer by integer*8 on the DEC Alpha
0017 C     64-bit platform
0018 C
0019       mwPointer PLHS(*), PRHS(*)
0020 C
0021 C-----------------------------------------------------------------------
0022 C
0023       mwSize NLHS, NRHS
0024 C
0025 C-----------------------------------------------------------------------
0026 C     (pointer) Replace integer by integer*8 on the DEC Alpha
0027 C     64-bit platform
0028 C
0029       mwPointer MXCREATEDOUBLEMATRIX, MXGETPR
0030 C
0031 C-----------------------------------------------------------------------
0032 C
0033 C
0034       mwSize MXGETM, MXGETN
0035 C
0036 C KEEP THE ABOVE SUBROUTINE, ARGUMENT, AND FUNCTION DECLARATIONS FOR USE
0037 C IN ALL YOUR FORTRAN MEX FILES.
0038 C---------------------------------------------------------------------
0039 C
0040 C-----------------------------------------------------------------------
0041 C     (pointer) Replace integer by integer*8 on the DEC Alpha
0042 C     64-bit platform
0043 C
0044       mwSize i,nx,nin
0045       mwPointer xrp,xip,zrp,zip,ninp 
0046       mwSize matone
0047       parameter (matone=1)
0048 C
0049       LOGICAL flag  
0050       PARAMETER (nx = 65536)   
0051 C
0052       real*8 ninr,xr(nx),xi(nx),yr,yi
0053       real*8 zr(nx),zi(nx)
0054 C
0055 C CHECK FOR PROPER NUMBER OF ARGUMENTS
0056 C
0057       IF (NRHS .NE. 3) THEN
0058         CALL MEXERRMSGTXT('erfcc_mex_jd requires 3 input arguments')
0059       ENDIF  
0060       IF (NLHS .GT. 2) THEN
0061         CALL MEXERRMSGTXT('erfcc_mex_jd requires 2 output arg. or less')
0062       ENDIF
0063 C
0064 C CHECK THE DIMENSIONS OF INPUTS.
0065 C
0066       IF ((MXGETM(PRHS(1)) .NE. 1).OR.(MXGETN(PRHS(1)).NE.1)) THEN
0067         CALL MEXERRMSGTXT('Argument 1 must be a scalar')
0068       ENDIF
0069 C
0070       ninp = MXGETPR(PRHS(1))
0071       CALL MXCOPYPTRTOREAL8(ninp, ninr, matone)
0072       nin = INT(ninr);
0073 C      print *, 'nin = ',nin
0074 C
0075       IF (nin .GT. 65536) THEN
0076         CALL MEXERRMSGTXT('nin must be <= 65536')
0077       ENDIF
0078 C
0079       IF (MXGETM(PRHS(2)) .NE. 1) THEN
0080         CALL MEXERRMSGTXT('Argument 2 must be a row vector')
0081       ENDIF
0082 C
0083       IF (MXGETM(PRHS(3)) .NE. 1) THEN
0084         CALL MEXERRMSGTXT('Argument 3 must be a row vector')
0085       ENDIF
0086 C
0087       IF (MXGETN(PRHS(2)) .NE. nx) THEN
0088         CALL MEXERRMSGTXT('Length of Arg. 2 must be 65536')
0089       ENDIF
0090 C
0091       IF (MXGETN(PRHS(3)) .NE. MXGETN(PRHS(2))) THEN
0092         CALL MEXERRMSGTXT('Arg. 1 and 2 must have the same size')
0093       ENDIF
0094 C
0095 C CREATE A MATRIX FOR RETURN ARGUMENT
0096 C
0097       PLHS(1) = MXCREATEDOUBLEMATRIX(matone,nx,0)
0098       PLHS(2) = MXCREATEDOUBLEMATRIX(matone,nx,0)
0099 C
0100 C ASSIGN POINTERS TO THE VARIOUS PARAMETERS
0101 C
0102       zrp = MXGETPR(PLHS(1))
0103       zip = MXGETPR(PLHS(2))
0104 C
0105       xrp = MXGETPR(PRHS(2))
0106       xip = MXGETPR(PRHS(3))
0107 C      print *, 'xrp = ',xrp,', xip = ',xip
0108 C
0109 C COPY RIGHT HAND ARGUMENTS TO LOCAL ARRAYS OR VARIABLES
0110 C
0111       CALL MXCOPYPTRTOREAL8(xrp, xr, nx)
0112       CALL MXCOPYPTRTOREAL8(xip, xi, nx)
0113 C
0114 C DO THE ACTUAL COMPUTATIONS IN A SUBROUTINE
0115 C       CREATED ARRAYS.
0116 C
0117       do 10 i=1,nin
0118 C        print *, 'i',i,', xr(i)',xr(i),', xi(i)',xi(i)
0119         CALL WOFZ(xr(i),xi(i),yr,yi,flag)
0120 C        yr = xr(i)
0121 C        yi = xi(i)
0122 C        print *, 'yr',yr,', yi',yi
0123         zr(i) = yr
0124         zi(i) = yi
0125    10 continue
0126 C
0127       do 20 i=(nin+1),nx-1
0128         zr(i) = 0.0
0129         zi(i) = 0.0
0130    20 continue
0131 C
0132 C COPY OUTPUT WHICH IS STORED IN LOCAL ARRAY TO MATRIX OUTPUT
0133       CALL MXCOPYREAL8TOPTR(zr, zrp, nx)
0134       CALL MXCOPYREAL8TOPTR(zi, zip, nx)
0135 C
0136       RETURN
0137       END