/usr/share/ncarg/tests/tgflas.f is in libncarg-data 6.3.0-6build1.
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 164 165 166 167 168 169 | PROGRAM TGFLAS
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 GFLAS(IERR)
C
C DEACTIVATE AND CLOSE WORKSTATION, CLOSE GKS.
C
CALL GDAWK (IWKID)
CALL GCLWK (IWKID)
CALL GCLKS
C
STOP
END
C
SUBROUTINE GFLAS (IERROR)
C
C PURPOSE To provide a simple demonstration of the
C GFLASH package.
C
C USAGE CALL GFLAS (IERROR)
C
C ARGUMENTS
C
C ON OUTPUT IERROR
C An integer variable
C = 0 If there is a normal exit from GFLASH,
C = 1 Otherwise
C
C I/O If there is a normal exit from GFLASH,
C the message
C
C GFLASH TEST SUCCESSFUL . . . SEE PLOTS TO
C VERIFY PERFORMANCE
C
C is written on unit 6
C
C PRECISION SINGLE
C
C REQUIRED LIBRARY GFLASH
C FILES
C
C LANGUAGE FORTRAN
C
C HISTORY Written by members of the
C Scientific Computing Division of NCAR,
C Boulder Colorado
C
C PORTABILITY FORTRAN 77
C
C NOTE The call to GOPWK will have to be modified
C when using a non-NCAR GKS package. The third
C argument must be the workstation type for WISS.
C
C
C Data for the graphical objects.
C
DATA TWOPI/6.283185/
DATA X0C, Y0C, RC, NPTC/ 0.325, 0.5, 0.10 , 210/
DATA X0P, Y0P, RP, NPTP/ 0.500, 0.5, 0.35 , 16/
DATA X0S, Y0S, RS / 0.675, 0.5, 0.10 /
C
C Establish the viewport and window.
C
CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
C
C Initialize the GFLASH package. If using a non-NCAR GKS package
C the final argument in the following call should be replaced with
C the workstation type for WISS.
C
CALL GOPWK(9,1,3)
C
C Put a circle in a buffer with identifier 1.
C
CALL GFLAS1(1)
DTHETA = TWOPI/NPTC
CALL FRSTPT(X0C+RC,Y0C)
DO 20 I=1,NPTC
ANG = DTHETA*REAL(I)
XC = RC*COS(ANG)
YC = RC*SIN(ANG)
CALL VECTOR(X0C+XC,Y0C+YC)
20 CONTINUE
CALL GFLAS2
C
C Put a polygonal fan in a buffer with identifier 2.
C
CALL GFLAS1(2)
DTHETA = TWOPI/NPTP
DO 10 I=1,NPTP
ANG = DTHETA*REAL(I)
XC = RP*COS(ANG)
YC = RP*SIN(ANG)
CALL LINE(X0P,Y0P,X0P+XC,Y0P+YC)
10 CONTINUE
CALL GFLAS2
C
C Put a square in a buffer with identifier 3.
C
CALL GFLAS1(3)
CALL FRSTPT(X0S+RS,Y0S+RS)
CALL VECTOR(X0S-RS,Y0S+RS)
CALL VECTOR(X0S-RS,Y0S-RS)
CALL VECTOR(X0S+RS,Y0S-RS)
CALL VECTOR(X0S+RS,Y0S+RS)
CALL GFLAS2
C
C Put a background perimeter in a buffer with identifier 4.
C
CALL GFLAS1(4)
CALL FRSTPT( 0.0, 0.0)
CALL VECTOR( 1.0, 0.0)
CALL VECTOR( 1.0, 1.0)
CALL VECTOR( 0.0, 1.0)
CALL VECTOR( 0.0, 0.0)
CALL GFLAS2
C
C Create plots.
C
C Frame 1 -- title, circle, and fan.
C
CALL PLCHLQ(0.5,0.91,'FRAME 1',25.,0.,0.)
CALL GFLAS3(1)
CALL GFLAS3(2)
CALL GFLAS3(4)
CALL FRAME
C
C Frame 2 -- fan, title, and square.
C
CALL GFLAS3(2)
CALL PLCHLQ(0.5,0.91,'FRAME 2',25.,0.,0.)
CALL GFLAS3(3)
CALL GFLAS3(4)
CALL FRAME
C
C Frame 3 -- circle, square, fan, and title (note that the change
C in window affects the PLCHLQ call, but not the elements
C in the buffers -- this illustrates the independent
C nature of the FLASH buffers).
C
CALL SET (0.,1.,0.,1.,0.,10.,0.,10.,1)
CALL GFLAS3(1)
CALL GFLAS3(3)
CALL GFLAS3(2)
CALL PLCHLQ(5.0,9.1,'FRAME 3',25.,0.,0.)
CALL GFLAS3(4)
CALL FRAME
C
C Close the GFLASH package.
C
CALL GCLWK(9)
C
END
|