/usr/share/ncarg/tests/tsrfac.f is in libncarg-data 6.2.0-3.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 | PROGRAM TSRFAC
C
C Define the error file, the Fortran unit number, the workstation type,
C and the workstation ID to be used in calls to GKS routines.
C
C PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1, IWKID=1) ! NCGM
C PARAMETER (IERRF=6, LUNIT=2, IWTYPE=8, IWKID=1) ! X Windows
C PARAMETER (IERRF=6, LUNIT=2, IWTYPE=11, IWKID=1) ! PDF
C PARAMETER (IERRF=6, LUNIT=2, IWTYPE=20, IWKID=1) ! PostScript
C
PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1, IWKID=1)
C
C OPEN GKS, OPEN WORKSTATION OF TYPE 1, ACTIVATE WORKSTATION
C
CALL GOPKS (IERRF, ISZDM)
CALL GOPWK (IWKID, LUNIT, IWTYPE)
CALL GACWK (IWKID)
C
C INVOKE DEMO DRIVER
C
CALL SRFAC(IERR)
C
C DEACTIVATE AND CLOSE WORKSTATION, CLOSE GKS.
C
CALL GDAWK (IWKID)
CALL GCLWK (IWKID)
CALL GCLKS
C
STOP
END
C
SUBROUTINE SRFAC (IERROR)
C
C PURPOSE To provide a simple demonstration of SRFACE.
C
C USAGE CALL SRFAC (IERROR)
C
C ARGUMENTS
C
C ON OUTPUT IERROR
C An integer variable
C = 0, if the test was successful,
C = 1, the test was not successful.
C
C I/O If the test is successful, the message
C
C SRFACE TEST EXECUTED--SEE PLOT TO CERTIFY
C
C is printed on unit 6. In addition, 2
C frames are produced on the machine graphics
C device. In order to determine if the test
C was successful, it is necessary to examine
C the plots.
C
C PRECISION Single
C
C LANGUAGE FORTRAN 77
C
C REQUIRED ROUTINES SRFACE
C
C REQUIRED GKS LEVEL 0A
C
C ALGORITHM The function
C
C Z(X,Y) = .25*(X + Y + 1./((X-.1)**2+Y**2+.09)
C -1./((X+.1)**2+Y**2+.09)
C
C for X = -1. to +1. in increments of .1, and
C Y = -1.2 to +1.2 in increments of .1,
C is computed. Then, entries EZSRFC and SURFACE
C are called to generate surface plots of Z.
C
C HISTORY SURFACE was first written in April 1979 and
C converted to FORTRAN 77 and GKS in March 1984.
C
C XX contains the X-direction coordinate values for Z(X,Y); YY contains
C the Y-direction coordinate values for Z(X,Y); Z contains the function
C values; S contains values for the line of sight for entry SRFACE;
C WORK is a work array; ANGH contains the angle in degrees in the X-Y
C plane to the line of sight; and ANGV contains the angle in degrees
C from the X-Y plane to the line of sight.
C
REAL XX(21) ,YY(25) ,Z(21,25) ,S(6) ,
1 WORK(1096)
C
DATA S(1), S(2), S(3), S(4), S(5), S(6)/
1 -8.0, -6.0, 3.0, 0.0, 0.0, 0.0/
C
DATA ANGH/45./, ANGV/15./
C
C Specify coordinates for plot titles. The values CX and CY
C define the center of the title string in a 0. to 1. range.
C
DATA CX/.5/, CY/.9/
C
C Initialize the error parameter.
C
IERROR = 0
C
C Fill the XX and YY coordinate arrays as well as the Z function array.
C
DO 20 I=1,21
X = .1*REAL(I-11)
XX(I) = X
DO 10 J=1,25
Y = .1*REAL(J-13)
YY(J) = Y
Z(I,J) = (X+Y+1./((X-.1)**2+Y**2+.09)-
1 1./((X+.1)**2+Y**2+.09))*.25
10 CONTINUE
20 CONTINUE
C
C Select the normalization transformation 0.
C
CALL GSELNT(0)
C
C
C Frame 1 -- The EZSRFC entry.
C
C Add the plot title using GKS calls.
C
C Set the text alignment to center the string in horizontal and vertical
C
CALL GSTXAL(2,3)
C
C Set the character height.
C
CALL GSCHH(.016)
C
C Write the text.
C
CALL GTX(CX,CY,'DEMONSTRATION PLOT FOR EZSRFC ENTRY OF SRFACE')
C
CALL EZSRFC (Z,21,25,ANGH,ANGV,WORK)
C
C
C Frame 2 -- The SRFACE entry.
C
C Add the plot title.
C
C Set the text alignment to center the string in horizontal and vertical
C
CALL GSTXAL(2,3)
C
C Set the character height.
C
CALL GSCHH(.016)
C
C Write the text.
C
CALL GTX(CX,CY,'DEMONSTRATION PLOT FOR SRFACE ENTRY OF SRFACE')
C
CALL SRFACE (XX,YY,Z,WORK,21,21,25,S,0.)
C
C This routine automatically generates frame advances.
C
WRITE (6,1001)
C
RETURN
C
1001 FORMAT (' SRFACE TEST EXECUTED--SEE PLOT TO CERTIFY')
C
END
|