Please note that to compile the graphics portion of the code below,
you must link with a double precision version of NCAR Graphics, or
else you need to convert the code back to single precision before you
call the graphics routines.
PROGRAM FTEX03
C
C Example of CURVSDP, CURVPSDP.
C
C Define dimensions, declare arrays.
C
PARAMETER (IDIM=10,IOUT=201)
DOUBLE PRECISION X
DOUBLE PRECISION Y
DOUBLE PRECISION YS
DOUBLE PRECISION YSP
DOUBLE PRECISION TEMP
DOUBLE PRECISION XO
DOUBLE PRECISION YOS
DOUBLE PRECISION YOSP
DOUBLE PRECISION SIGMA
DOUBLE PRECISION D
DOUBLE PRECISION S
DOUBLE PRECISION EPS
DOUBLE PRECISION XR
DOUBLE PRECISION XL
DOUBLE PRECISION XINC
DOUBLE PRECISION CURV2DP
DOUBLE PRECISION P
DOUBLE PRECISION CURVP2DP
DOUBLE PRECISION YO
DIMENSION X(IDIM),Y(IDIM),YS(IDIM),YSP(IDIM),TEMP(IDIM,11)
DIMENSION XO(IOUT),YOS(IOUT),YOSP(IOUT)
C
C Specify the input data.
C
C
DATA X/0.000D0,0.210D0,0.360D0,0.540D0,1.000D0,1.500D0,1.970D0,
+ 2.300D0,2.500D0,2.700D0/
DATA Y/0.000D0,2.600D0,3.000D0,2.500D0,0.000D0,-1.000D0,0.000D0,
+ 0.800D0,0.920D0,0.700D0/
C
C Call CURVSDP setup.
C
SIGMA = 1.0D0
D = 0.3D0
ISW = 1
S = DBLE(IDIM)
EPS = SQRT(2.D0/S)
CALL CURVSDP(IDIM,X,Y,D,ISW,S,EPS,YS,YSP,SIGMA,TEMP,IERR)
C
C Call CURVP2DP and calculate the interpolated values and the integrals.
C
XR = 5.D0
XL = -1.D0
XINC = (XR-XL)/ (IOUT-1)
DO 10 I = 1,IOUT
XO(I) = XL + (I-1)*XINC
YOS(I) = CURV2DP(XO(I),IDIM,X,YS,YSP,SIGMA)
10 CONTINUE
C
C Call CURVPSDP setup.
C
P = 3.D0
CALL CURVPSDP(IDIM,X,Y,P,D,ISW,S,EPS,YS,YSP,SIGMA,TEMP,IERR)
C
C Call CURVP2DP and calculate the interpolated values.
C
DO 15 I = 1,IOUT
YOSP(I) = CURVP2DP(XO(I),IDIM,X,YS,P,YSP,SIGMA)
15 CONTINUE
C
C Plot the results.
C
CALL DRWFT3(XL,XR,IDIM,X,Y,IOUT,XO,YO,YOS,YOSP)
C
STOP
END
SUBROUTINE DRWFT3(XL,XR,II,X,Y,IO,XO,YO,YOS,YOSP)
C
C Define error file, Fortran unit number, and workstation type,
C and workstation ID.
C
PARAMETER (IERRF=6,LUNIT=2,IWTYPE=1,IWKID=1)
DOUBLE PRECISION XL
DOUBLE PRECISION XR
DOUBLE PRECISION X
DOUBLE PRECISION Y
DOUBLE PRECISION XO
DOUBLE PRECISION YO
DOUBLE PRECISION YOS
DOUBLE PRECISION YOSP
DOUBLE PRECISION YPOS_TOP
DOUBLE PRECISION YB
DOUBLE PRECISION YT
C
DATA YPOS_TOP/0.95D0/
C
C Open GKS, open and activate a workstation.
C
CALL GOPKS(IERRF,ISZDM)
CALL GOPWK(IWKID,LUNIT,IWTYPE)
CALL GACWK(IWKID)
C
C Define a color table.
C
CALL GSCR(IWKID,0,1.0D0,1.0D0,1.0D0)
CALL GSCR(IWKID,1,0.0D0,0.0D0,0.0D0)
CALL GSCR(IWKID,2,1.0D0,0.0D0,0.0D0)
CALL GSCR(IWKID,3,0.0D0,1.0D0,0.0D0)
CALL GSCR(IWKID,4,0.0D0,0.0D0,1.0D0)
CALL GSCLIP(1)
C
C Graph the interpolated function values and mark the original
C input data points.
C
YB = -2.0D0
YT = 4.0D0
CALL BKGFT3(XL,XR,YPOS_TOP,'CURVSDP',0.42D0,YB,YT)
CALL GRIDAL(6,5,3,1,1,1,10,XL,YB)
C
C Mark the original data points.
C
CALL GSMKSC(2.D0)
CALL GSPMCI(4)
CALL GPM(II,X,Y)
C
C Graph the interpolated function values.
C
CALL GPL(IO,XO,YOS)
C
C Graph the periodic function.
C
CALL BKGFT3(XL,XR,YPOS_TOP-0.5D0,'CURVPSDP',0.42D0,YB,YT)
CALL GRIDAL(6,5,3,1,1,1,10,XL,YB)
CALL GPL(IO,XO,YOSP)
CALL GSPLCI(1)
C
C Mark the original data points.
C
CALL GSMKSC(2.D0)
CALL GSPMCI(4)
CALL GPM(II,X,Y)
C
CALL FRAME
C
CALL GDAWK(IWKID)
CALL GCLWK(IWKID)
CALL GCLKS
C
RETURN
END
SUBROUTINE BKGFT3(XL,XR,YPOS,LABEL,XLP,YB,YT)
DOUBLE PRECISION XL
DOUBLE PRECISION XR
DOUBLE PRECISION YPOS
DOUBLE PRECISION XLP
DOUBLE PRECISION YB
DOUBLE PRECISION YT
DOUBLE PRECISION XX
DOUBLE PRECISION YY
DIMENSION XX(2),YY(2)
CHARACTER*(*) LABEL
C
CALL SET(0.D0,1.D0,0.D0,1.D0,0.D0,1.D0,0.D0,1.D0,1)
CALL PCSETI('FN',21)
CALL PLCHHQ(XLP,YPOS-0.03D0,LABEL,0.025D0,0.D0,-1.D0)
CALL SET(0.13D0,0.93D0,YPOS-0.35D0,YPOS,XL,XR,YB,YT,1)
XX(1) = XL
XX(2) = XR
YY(1) = 0.D0
YY(2) = 0.D0
CALL GSPLCI(2)
CALL GPL(2,XX,YY)
CALL GSPLCI(1)
CALL GASETI('LTY',1)
CALL PCSETI('FN',21)
CALL GASETR('XLS',0.02D0)
CALL GASETC('XLF','(F4.1)')
CALL GASETR('YLS',0.02D0)
CALL GASETC('YLF','(F5.2)')
CALL GASETR('XMJ',0.02D0)
CALL GASETR('YMJ',0.02D0)
C
RETURN
END
home |
contents |
defs |
params |
procedures |
exmpls