/usr/share/ncarg/tests/tisosr.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 | PROGRAM TISOSR
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 ISOSR(IERR)
C
C DEACTIVATE AND CLOSE WORKSTATION, CLOSE GKS.
C
CALL GDAWK (IWKID)
CALL GCLWK (IWKID)
CALL GCLKS
C
STOP
END
C
SUBROUTINE ISOSR (IERROR)
C
C PURPOSE To provide a simple demonstration of ISOSRF.
C
C USAGE CALL ISOSR (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 ISOSRF TEST EXECUTED--SEE PLOTS 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 ISOSRF
C
C REQUIRED GKS LEVEL 0A
C
C ALGORITHM Values of a function on a 3-D rectangular grid
C are stored in array T. Entries EZISOS and
C ISOSRF are called to draw iso-valued surface
C plots of the function.
C
SAVE
DIMENSION T(21,31,19),SLAB(33,33),EYE(3)
C
C Specify coordinates for plot titles.
C
REAL IX,IY
DATA IX/.44/, IY/.95/
C
DATA NU,NV,NW/21,31,19/
DATA RBIG1,RBIG2,RSML1,RSML2/6.,6.,2.,2./
DATA TISO/0./
DATA MUVWP2/33/
DATA IFLAG/-7/
C
C Initialize the error parameter.
C
IERROR = 1
C
C Fill the 3-D array to be plotted.
C
JCENT1 = REAL(NV)*.5-RBIG1*.5
JCENT2 = REAL(NV)*.5+RBIG2*.5
DO 30 I=1,NU
FIMID = I-NU/2
DO 20 J=1,NV
FJMID1 = J-JCENT1
FJMID2 = J-JCENT2
DO 10 K=1,NW
FKMID = K-NW/2
F1 = SQRT(RBIG1*RBIG1/(FJMID1*FJMID1+FKMID*FKMID+.1))
F2 = SQRT(RBIG2*RBIG2/(FIMID*FIMID+FJMID2*FJMID2+.1))
FIP1 = (1.-F1)*FIMID
FIP2 = (1.-F2)*FIMID
FJP1 = (1.-F1)*FJMID1
FJP2 = (1.-F2)*FJMID2
FKP1 = (1.-F1)*FKMID
FKP2 = (1.-F2)*FKMID
T(I,J,K) = MIN(FIMID*FIMID+FJP1*FJP1+FKP1*FKP1-
1 RSML1*RSML1,
2 FKMID*FKMID+FIP2*FIP2+FJP2*FJP2-RSML2*RSML2)
10 CONTINUE
20 CONTINUE
30 CONTINUE
C
C Define the eye position.
C
EYE(1) = 100.
EYE(2) = 150.
EYE(3) = 125.
C
C
C Frame 1 -- The EZISOS entry.
C
C Select normalization transformation 0.
C
CALL GSELNT(0)
C
C Call PLCHLQ to write the plot title.
C
CALL PLCHLQ(IX,IY,'DEMONSTRATION PLOT FOR ENTRY EZISOS OF ISOSRF',
1 16.,0.,0.)
CALL EZISOS (T,NU,NV,NW,EYE,SLAB,TISO)
C
C
C Frame 2 -- The ISOSRF entry.
C
C Select normalization transformation 0.
C
CALL GSELNT(0)
C
C Call PLCHLQ to write the plot title.
C
CALL PLCHLQ(IX,IY,'DEMONSTRATION PLOT FOR ENTRY ISOSRF OF ISOSRF',
1 16.,0.,0.)
C
C Test ISOSRF with a subarray of T.
C
MU=NU/2
MV=NV/2
MW=NW/2
MUVWP2=MAX(MU,MV,MW)+2
CALL ISOSRF(T(MU,MV,MW),NU,MU,NV,MV,MW,EYE,MUVWP2,SLAB,TISO,IFLAG)
CALL FRAME
C
IERROR = 0
WRITE (6,1001)
RETURN
C
1001 FORMAT (' ISOSRF TEST EXECUTED--SEE PLOTS TO CERTIFY')
C
END
|