diff options
Diffstat (limited to 'sys/gio/ncarutil/tests/isosrfhrt.f')
| -rw-r--r-- | sys/gio/ncarutil/tests/isosrfhrt.f | 165 |
1 files changed, 165 insertions, 0 deletions
diff --git a/sys/gio/ncarutil/tests/isosrfhrt.f b/sys/gio/ncarutil/tests/isosrfhrt.f new file mode 100644 index 00000000..1d8fb249 --- /dev/null +++ b/sys/gio/ncarutil/tests/isosrfhrt.f @@ -0,0 +1,165 @@ + SUBROUTINE TISOHR (IERROR) +C +C LATEST REVISION JULY 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C THE ISOSRFHR PACKAGE +C +C USAGE CALL TISOHR (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C =0 IF THERE IS A NORMAL EXIT FROM THE +C ISOSRFHR ROUTINES +C =1 OTHERWISE +C +C I/O THIS ROUTINE REQUIRES UNIT IUNIT FOR SCRATCH +C PURPOSES. USERS SHOULD PUT THE UNITS LABELLED +C COMMON (SEE BELOW) IN THE CALLING PROGRAM, +C AND ALSO SET THE VALUE OF THE COMMON VARIABLE +C IUNIT IN THE CALLING PROGRAM. +C +C IF THERE IS A NORMAL EXIT FROM THE +C ISOSRFHR ROUTINES THE MESSAGE +C ISOSRFHR TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C IS PRINTED. +C +C ALSO, A SAMPLE PLOT IS +C PRODUCED ON THE MACHINE GRAPHICS +C DEVICE. ONE MUST EXAMINE THIS PLOT +C TO DETERMINE IF THE ROUTINES HAVE +C EXECUTED CORRECTLY. +C +C COMMON BLOCKS UNITS +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY ISOSRFHR +C FILES +C +C LANGUAGE FORTRAN +C +C ALGORITHM THIS SUBROUTINE USES THE ROUTINES IN +C THE PACKAGE ISOSRFHR TO DRAW A PERSPECTIVE +C DRAWING OF TWO INTERLOCKING DOUGHNUTS +C +C PORTABILITY ANSI STANDARD +C +C + DIMENSION EYE(3) ,S(4) ,IS2(4,200) , + 1 ST1(81,51,2) ,IOBJS(81,51) + COMMON /UNITS/ IUNIT +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE INTEGER COORDINATES RANGE FROM 1 TO 1024, THE VALUES IX AND IY +C DEFINE THE CENTER OF THE TITLE STRING. +C + DATA IX/448/, IY/990/ +C +C +C DEFINE THE EYE POSITION +C + DATA EYE(1), EYE(2), EYE(3) / 200., 250., 250. / +C +C DEFINE THE OVERALL DIMENSION OF THE BOX CONTAINING THE OBJECTS +C + DATA NU, NV, NW / 51, 81, 51 / +C +C SPECIFY THE DIMENSIONS OF THE MODEL OF THE IMAGE PLANE +C + DATA LX, NX, NY / 4, 180, 180 / +C +C SPECIFY CRT COORDINATES OF THE AREA WHERE THE PICTURE +C IS TO BE DRAWN +C + DATA S(1),S(2),S(3),S(4)/ 10.,1010.,10.,1010./ + DATA MV / 81 / +C +C SPECIFY THE LARGE AND SMALL RADII FOR THE INDIVIDUAL DOUGHNUTS +C + DATA RBIG1,RBIG2,RSML1,RSML2/ 20., 20., 6., 6. / +C + SAVE +C +C CALL THE INITIALIZATION ROUTINE +C + CALL INIT3D (EYE,NU,NV,NW,ST1,LX,NY,IS2,IUNIT,S) +C +C INITIALIZE THE ERRROR FLAG +C + IERROR = 1 +C +C CREATE AND PLOT DATA FOR TWO INTERLOCKING DOUGHNUTS +C + JCENT1 = FLOAT(NV)*.5-RBIG1*.5 + JCENT2 = FLOAT(NV)*.5+RBIG2*.5 + DO 70 IBKWDS=1,NU + I = NU+1-IBKWDS +C +C CREATE THE I-TH CROSS SECTION IN THE U DIRECTION OF THE +C THREE-DIMENSIONAL ARRAY AND STORE IN IOBJS AS ZEROS AND ONES +C + 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 + TEMP = AMIN1(FIMID**2+FJP1**2+FKP1**2-RSML1**2, + 1 FKMID**2+FIP2**2+FJP2**2-RSML2**2) + IF (TEMP .LE. 0.) IOBJS(J,K) = 1 + IF (TEMP .GT. 0.) IOBJS(J,K) = 0 + 10 CONTINUE + 20 CONTINUE +C +C SET PROPER WORDS TO 1 FOR DRAWING AXES +C + IF (I .NE. 1) GO TO 50 + DO 30 K=1,NW + IOBJS(1,K) = 1 + 30 CONTINUE + DO 40 J=1,NV + IOBJS(J,1) = 1 + 40 CONTINUE + GO TO 60 + 50 CONTINUE + IOBJS(1,1) = 1 + 60 CONTINUE +C +C CALL THE DRAW AND REMEMBER ROUTINE FOR THIS SLAB +C + CALL DANDR (NV,NW,ST1,LX,NX,NY,IS2,IUNIT,S,IOBJS,MV) + 70 CONTINUE +C +C TITLE THE PLOT +C + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + XC = PAU2FX(IX) + YC = PAU2FY(IY) + CALL WTSTR(XC,YC,'DEMONSTRATION PLOT FOR ISOSRFHR',2,0,0) + CALL GSELNT(ICN) +C +C ADVANCE THE PLOTTING DEVICE +C +c CALL NEWFM +C + IERROR = 0 +c WRITE (6,1001) + RETURN +C +c1001 FORMAT (' ISOSRFHR TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END |