Previous topic |
Next topic |
Contents |
Index |
Contact z/OS |
Library |
PDF |
BOOK
![]() Appendix D. ROOM program source code GDDM-GKS V1R1 Programming Guide and Reference SC33-0334-00 |
|
This section contains the complete FORTRAN source code for the ROOM program that was discussed in "Using GKS." This program is written so that it can be compiled by the VS FORTRAN and FORTRAN IV compilers. It therefore does not use some techniques that would usually be found in programs written only for the VS FORTRAN compiler. C********************************************************************** ADM00010 C** ** ADM00020 C** 5666-802 ** ADM00030 C** (C) COPYRIGHT IBM CORP. 1987 ** ADM00040 C** LICENSED MATERIALS - PROPERTY OF IBM ** ADM00050 C** ** ADM00060 C** ADMJROOM ** ADM00070 C** ** ADM00080 C** A SAMPLE FORTRAN PROGRAM TO DO A SIMPLE ROOM LAYOUT WITH ** ADM00090 C** TWO FURNITURE SELECTIONS FOR PLACEMENT WITHIN A ROOM. ** ADM00100 C** ** ADM00110 C** ** ADM00120 C********************************************************************** ADM00130 C ADM00140 C*** Control variables ADM00150 C ADM00160 C - Segment number, message flag ADM00170 INTEGER SEGNUM,MSGFLG ADM00180 C - Pick flag, position flag ADM00190 INTEGER PCKFLG,POSFLG ADM00200 C ADM00210 C*** Program data ADM00220 C ADM00230 C - Room Outline ADM00240 REAL XRRY1(7),YRRY1(7) ADM00250 C - Initial desk outline ADM00260 REAL XDRY(5),YDRY(5) ADM00270 C - Desk ADM00280 REAL XDSK(5),YDSK(5) ADM00290 C - Initial chair outline ADM00300 REAL XCHRY1(9),YCHRY1(9),XCHRY2(2) ADM00310 REAL YCHRY2(2),XCHRY3(5),YCHRY3(5) ADM00320 C - Chair ADM00330 REAL XCHR1(9),YCHR1(9),XCHR2(2),YCHR2(2) ADM00340 REAL XCHR3(5),YCHR3(5) ADM00350 C - Furniture width and height ADM00360 REAL FURWDT,FURHIG ADM00370 C ADM00380 C*** GKS input parameters ADM00390 C ADM00400 C - Workstation identifier, workstation type ADM00410 INTEGER WKID1,WKTYPE ADM00420 C - Normalization transformation viewport size ADM00430 REAL XNDC,YNDC ADM00440 C - Echo area for valuator input (minimum x/y values) ADM00450 REAL MINXDC,MINYDC ADM00460 C - X, Y shift for transformation matrix ADM00470 REAL SHFTX,SHFTY ADM00480 C - Rotation angle ADM00490 REAL ANG ADM00500 C - Data record ADM00510 LOGICAL*1 DATREC(80) ADM00520 C ADM00530 C*** GKS output parameters ADM00540 C ADM00550 C - Error indicator, device coordinate units ADM00560 INTEGER ERRIND,DCUNIT ADM00570 C - Maximum display surface size in DC and Raster units ADM00580 REAL XDC,YDC ADM00590 INTEGER XRAS,YRAS ADM00600 C - Number of segment names, nth set member of set of stored segments ADM00610 INTEGER NUMSEG,SEGN ADM00620 C - Input device status, choice number ADM00630 INTEGER STAT,CHCNUM ADM00640 C - Picked segment number, pick identifier ADM00650 INTEGER SEGNM,PICKID ADM00660 C - Locator returned transformation number and position ADM00670 INTEGER TRANUM ADM00680 REAL XPOP,YPOP ADM00690 C - Transformation matrices ADM00700 REAL MTX(6),MTX2(6) ADM00710 C ADM00720 C*** Work variables ADM00730 C ADM00740 REAL RTEMP ADM00750 INTEGER J ADM00760 C ADM00770 C*** Initial values ADM00780 C ADM00790 C - Workstation identifier, workstation type ADM00800 DATA WKTYPE /1/ ADM00810 DATA WKID1 /1/ ADM00820 C - Room Outline ADM00830 DATA XRRY1 /00.0,00.0,60.0,60.0,00.0,00.0,10.5/ ADM00840 DATA YRRY1 /55.0,99.8,99.8,34.0,34.0,36.0,49.4/ ADM00850 C - Initial desk outline ADM00860 DATA XDRY /75.0,100.0,100.0,75.0,75.0/ ADM00870 DATA YDRY /87.0,87.0,100.0,100.0,87.0/ ADM00880 C - Desk ADM00890 DATA XDSK /00.0,25.0,25.0,00.0,00.0/ ADM00900 DATA YDSK /00.0,00.0,13.0,13.0,00.0/ ADM00910 C - Initial chair outline ADM00920 DATA XCHRY1 /93.0,93.0,94.0,94.0,99.0,99.0,100.0, ADM00930 $ 100.0,93.0/ ADM00940 DATA YCHRY1 /73.0,80.0,80.0,73.0,73.0,80.0,80.0, ADM00950 $ 73.0,73.0/ ADM00960 DATA XCHRY2 /94.0,99.0/ ADM00970 DATA YCHRY2 /79.0,79.0/ ADM00980 DATA XCHRY3 /93.0,93.0,100.0,100.0,93.0/ ADM00990 DATA YCHRY3 /73.0,80.0,80.0,73.0,73.0/ ADM01000 C - Chair ADM01010 DATA XCHR1 /00.0,00.0,01.0,01.0,06.0,06.0,07.0,07.0,00.0/ ADM01020 DATA YCHR1 /00.0,07.0,07.0,00.0,00.0,07.0,07.0,00.0,00.0/ ADM01030 DATA XCHR2 /01.0,06.0/ ADM01040 DATA YCHR2 /06.0,06.0/ ADM01050 DATA XCHR3 /00.0,00.0,07.0,07.0,00.0/ ADM01060 DATA YCHR3 /00.0,07.0,07.0,00.0,00.0/ ADM01070 C ADM01080 C******************************************************************** ADM01090 C* INITIALISATION * ADM01100 C******************************************************************** ADM01110 C ADM01120 C*** OPEN GKS ADM01130 CALL GOPKS(1,0) ADM01140 C ADM01150 C******************************************************************** ADM01160 C* Open and activate all the workstations to be used * ADM01170 C******************************************************************** ADM01180 C ADM01190 CALL GOPWK(WKID1,1,WKTYPE) ADM01200 CALL GACWK(WKID1) ADM01210 C ADM01220 C******************************************************************** ADM01230 C* Set normalization and workstation transformation * ADM01240 C******************************************************************** ADM01250 C ADM01260 C - Set world window (user units) ADM01270 CALL GSWN(1,0.0,100.0,0.0,100.0) ADM01280 C - Inquire maximum display surface size ADM01290 CALL GQDSP(WKTYPE,ERRIND,DCUNIT,XDC,YDC,XRAS,YRAS) ADM01300 C - Find the larger of the two dimensions ADM01310 RTEMP = XDC ADM01320 IF (RTEMP .LT. YDC) RTEMP = YDC ADM01330 C - Calculate aspect ratio of the display surface ADM01340 XNDC = XDC / RTEMP ADM01350 YNDC = YDC / RTEMP ADM01360 C - Set viewport and WK window to same ratio ADM01370 CALL GSVP(1,0.0,XNDC,0.0,YNDC) ADM01380 CALL GSWKWN(WKID1,0.0,XNDC,0.0,YNDC) ADM01390 C - Select transformation 1 ADM01400 CALL GSELNT(1) ADM01410 C ADM01420 C******************************************************************** ADM01430 C* Output initial segments to display * ADM01440 C******************************************************************** ADM01450 C ADM01460 C*** Create segment 100: 2 items ADM01470 CALL GCRSG(100) ADM01480 C ADM01490 C Set pick ID to 101 for the first item ADM01500 CALL GSPKID(101) ADM01510 C - Set fill color to background color ADM01520 CALL GSFACI(0) ADM01530 C - Set fill interior style to solid ADM01540 CALL GSFAIS(1) ADM01550 C - Output an invisible fill area ADM01560 CALL GFA(5,XDRY,YDRY) ADM01570 C - Set line color to index 1 ADM01580 CALL GSPLCI(1) ADM01590 C - Output a polyline to make a desk ADM01600 CALL GPL(5,XDRY,YDRY) ADM01610 C - Set text color and output text identifier ADM01620 CALL GSTXCI(3) ADM01630 CALL GTXS(78.5,92.0,4,'desk') ADM01640 C ADM01650 C Set pick ID to 102 for the second item ADM01660 CALL GSPKID(102) ADM01670 C - Output an invisible fill area ADM01680 CALL GFA(5,XCHRY3,YCHRY3) ADM01690 C - Output 2 polylines to make a chair ADM01700 CALL GPL(9,XCHRY1,YCHRY1) ADM01710 CALL GPL(2,XCHRY2,YCHRY2) ADM01720 C - Output text identifier ADM01730 CALL GTXS(86.0,73.5,5,'chair') ADM01740 C ADM01750 C*** Close segment 100 ADM01760 CALL GCLSG ADM01770 C*** Make the segment detectable ADM01780 CALL GSDTEC(100,1) ADM01790 C ADM01800 C*** Create segment 200 : Room outline ADM01810 CALL GCRSG(200) ADM01820 C - Set line color ADM01830 CALL GSPLCI(2) ADM01840 C - Output lines for room outline ADM01850 CALL GPL(7,XRRY1,YRRY1) ADM01860 C ADM01870 C*** Close segment 200 ADM01880 CALL GCLSG ADM01890 C ADM01900 C*** Create segment 300: Choice menu ADM01910 CALL GCRSG(300) ADM01920 CALL GSTXCI(6) ADM01930 CALL GTXS(02.0,26.0,14,'PF1-pick furn.') ADM01940 CALL GTXS(02.0,22.0,15,'PF2-place furn.') ADM01950 CALL GTXS(02.0,18.0,16,'PF3-rotate furn.') ADM01960 CALL GTXS(53.0,26.0,16,'PF4-remove furn.') ADM01970 CALL GTXS(53.0,22.0, 8,'PF5-exit') ADM01980 C ADM01990 C*** Close segment 300 ADM02000 CALL GCLSG ADM02010 C ADM02020 C******************************************************************** ADM02030 C* Initialize input functions * ADM02040 C******************************************************************** ADM02050 C ADM02060 C*** Initialize valuator ADM02070 MINXDC = XDC/8.0 ADM02080 MINYDC = YDC/10.0 ADM02090 CALL GINVL(WKID1,1,0.0,1,MINXDC,XDC,MINYDC,YDC, ADM02100 $ -360.0,+360.0,0,DATREC) ADM02110 C ADM02120 C*** Initialize locator with initial cursor position ADM02130 CALL GINLC(WKID1,1,1,29.93,69.51,1,0.0,XDC,0.0,YDC,0, ADM02140 $ DATREC) ADM02150 C ADM02160 C*** Set viewport input priority ADM02170 CALL GSVPIP(1,0,0) ADM02180 C ADM02190 C*** Set attributes and initial flags ADM02200 C ADM02210 C Set all the following output text color to 2 ADM02220 CALL GSTXCI(2) ADM02230 C ADM02240 C Set the type of all following lines to solid ADM02250 CALL GSLN(1) ADM02260 C ADM02270 C Initialise segment number, message flag ADM02280 SEGNUM = 0 ADM02290 MSGFLG = 0 ADM02300 C ADM02310 C******************************************************************** ADM02320 C* BEGIN USER INPUT - REPEAT UNTIL OPTION 5(EXIT) IS PICKED * ADM02330 C******************************************************************** ADM02340 C ADM02350 C Inquire number of segments on workstation. If there are no ADM02360 C segments other than the 3 segments in the initial screen, set ADM02370 C pick flag and position flag to be off ADM02380 C ADM02390 1000 CALL GQSGWK(WKID1,1,ERRIND,NUMSEG,SEGN) ADM02400 IF (NUMSEG .GT. 3) GOTO 1100 ADM02410 PCKFLG = 0 ADM02420 POSFLG = 0 ADM02430 1100 CONTINUE ADM02440 C ADM02450 C*** If a message already exists do not output another ADM02460 C ADM02470 IF (MSGFLG .NE. 0) GOTO 1200 ADM02480 C Call REDRAW ALL SEGMENTS to clear msg area ADM02490 CALL GRSGWK(WKID1) ADM02500 CALL GTXS(1.0,1.0,30,'Enter option 1-5 using PF key ') ADM02510 1200 MSGFLG = 0 ADM02520 C ADM02530 C*** Request choice until status is OK and choice is 1 to 5 ADM02540 C ADM02550 1300 CALL GRQCH(WKID1,2,STAT,CHCNUM) ADM02560 IF ((STAT .NE. 1) .OR. (CHCNUM .GT. 5) .OR. (CHCNUM .LT. 1)) ADM02570 $ GOTO 1300 ADM02580 C ADM02590 C ***************************************************************** ADM02600 C ***IF PICK FURNITURE IS CHOSEN * ADM02610 C ***************************************************************** ADM02620 C ADM02630 IF (CHCNUM .NE. 1) GOTO 2400 ADM02640 C ADM02650 C Call REDRAW ALL SEGMENTS to clear msg area ADM02660 C Display msg asking user to pick furniture ADM02670 C ADM02680 CALL GRSGWK(WKID1) ADM02690 CALL GTXS(1.0,1.0,15,'Pick furniture ') ADM02700 2000 CALL GRQPK (WKID1, 1, STAT, SEGNM, PICKID) ADM02710 IF (STAT .EQ. 0) GOTO 2000 ADM02720 C ADM02730 C *** Test for invalid segment and status equal 2 'no pick' ADM02740 IF ((SEGNM .EQ. 100) .AND. (STAT .NE. 2)) GOTO 2100 ADM02750 C call REDRAW ALL SEGMENTS to clear msg area ADM02760 CALL GRSGWK(WKID1) ADM02770 CALL GSTXI(2) ADM02780 CALL GTXS(1.0,1.0,35, ADM02790 $ 'Selection is invalid - pick again ') ADM02800 CALL GSTXI(1) ADM02810 GOTO 2000 ADM02820 2100 CONTINUE ADM02830 C ADM02840 PCKFLG = 1 ADM02850 SEGNUM = SEGNUM + 1 ADM02860 C ADM02870 C*** Switch according to the furniture picked ADM02880 IF (PICKID .NE. 101) GOTO 2200 ADM02890 C Create a desk segment ADM02900 CALL GCRSG(SEGNUM) ADM02910 CALL GSPKID(SEGNUM) ADM02920 C - Set the segment invisible before it is placed ADM02930 CALL GSVIS(SEGNUM,0) ADM02940 C - Output a fill area with background color ADM02950 CALL GFA(5,XDSK,YDSK) ADM02960 CALL GPL(5,XDSK,YDSK) ADM02970 CALL GCLSG ADM02980 FURWDT=12.5 ADM02990 FURHIG=6.5 ADM03000 2200 CONTINUE ADM03010 C ADM03020 IF (PICKID .NE. 102) GOTO 2300 ADM03030 C Create a chair segment ADM03040 CALL GCRSG(SEGNUM) ADM03050 CALL GSPKID(SEGNUM) ADM03060 C - Set the segment invisible before it is placed ADM03070 CALL GSVIS(SEGNUM,0) ADM03080 C - Output a fill with background color ADM03090 CALL GFA(5,XCHR3,YCHR3) ADM03100 CALL GPL(9,XCHR1,YCHR1) ADM03110 CALL GPL(2,XCHR2,YCHR2) ADM03120 CALL GCLSG ADM03130 FURWDT=3.5 ADM03140 FURHIG=3.5 ADM03150 2300 CONTINUE ADM03160 2400 CONTINUE ADM03170 C ADM03180 C ****************************************************************** ADM03190 C ***IF PLACE FURNITURE IS CHOSEN * ADM03200 C ****************************************************************** ADM03210 C ADM03220 IF (CHCNUM .NE. 2) GOTO 3100 ADM03230 C*** If no furniture is picked yet, display error message and exit ADM03240 IF (PCKFLG .NE. 0) GOTO 2900 ADM03250 C Call REDRAW ALL SEGMENTS to clear msg area ADM03260 CALL GRSGWK(WKID1) ADM03270 CALL GTXS(1.0,1.0,29,'You must pick furniture first') ADM03280 MSGFLG = 1 ADM03290 GOTO 1000 ADM03300 2900 CONTINUE ADM03310 C ADM03320 C*** Display msg asking user to place the furniture ADM03330 C Call REDRAW ALL SEGMENTS to clear msg area ADM03340 CALL GRSGWK(WKID1) ADM03350 CALL GTXS(1.0,1.0,33,'Place furniture in the room ') ADM03360 C ADM03370 C*** Request locator until the furniture is inside the room ADM03380 3000 CALL GRQLC(WKID1, 1, STAT, TRANUM, XPOP, YPOP) ADM03390 IF ((STAT .EQ. 0) .OR. (XPOP .GT. 60.0) .OR. (YPOP .LT. 40.0))ADM03400 $ GOTO 3000 ADM03410 POSFLG = 1 ADM03420 C ADM03430 C*** Transform the furniture and make the center point of the ADM03440 C furniture locate at the point just entered ADM03450 C ADM03460 SHFTX = XPOP-FURWDT ADM03470 SHFTY = YPOP-FURHIG ADM03480 CALL GEVTM(0.0,0.0,SHFTX,SHFTY,0.0,1.0,1.0,0,MTX) ADM03490 CALL GSSGT(SEGNUM,MTX) ADM03500 C ADM03510 C*** Make the segment visible ADM03520 CALL GSVIS(SEGNUM,1) ADM03530 C*** and detectable ADM03540 CALL GSDTEC(SEGNUM,1) ADM03550 3100 CONTINUE ADM03560 C ADM03570 C ****************************************************************** ADM03580 C ***IF ROTATE FURNITURE IS CHOSEN * ADM03590 C ****************************************************************** ADM03600 C ADM03610 IF (CHCNUM .NE. 3) GOTO 4300 ADM03620 C ADM03630 C*** If this furniture is not positioned yet, display error ADM03640 C and exit ADM03650 IF (POSFLG .NE. 0) GOTO 3900 ADM03660 C Call REDRAW ALL SEGMENTS to clear msg area ADM03670 CALL GRSGWK(WKID1) ADM03680 CALL GSTXI(2) ADM03690 CALL GTXS(1.0,1.0,38, ADM03700 $ 'You must position furniture first ') ADM03710 CALL GSTXI(1) ADM03720 MSGFLG = 1 ADM03730 GOTO 1000 ADM03740 3900 CONTINUE ADM03750 C ADM03760 C*** Display msg asking user to enter rotation angle ADM03770 C Call REDRAW ALL SEGMENTS to clear msg area ADM03780 CALL GRSGWK(WKID1) ADM03790 CALL GTXS(1.0,1.0,33,'Enter rotation angle in degrees ') ADM03800 CALL GTXS(1.0,10.0, 6,'angle:') ADM03810 4000 CALL GRQVL(WKID1,1,STAT,ANG) ADM03820 IF (STAT .NE. 1 ) GOTO 4000 ADM03830 C ADM03840 C Convert degrees to radians ADM03850 4200 ANG = ANG/180*3.1416 ADM03860 C ADM03870 C*** Accumulate the transformation matrix and set transformation ADM03880 CALL GACTM(MTX,XPOP,YPOP,0.0,0.0,ANG,1.0,1.0,0,MTX2) ADM03890 CALL GSSGT(SEGNUM,MTX2) ADM03900 C ADM03910 4300 CONTINUE ADM03920 C ADM03930 C ****************************************************************** ADM03940 C ***IF REMOVE FURNITURE IS CHOSEN * ADM03950 C ****************************************************************** ADM03960 C ADM03970 IF (CHCNUM .NE. 4) GOTO 5100 ADM03980 C ADM03990 C*** If no furniture is in the room, display error message ADM04000 IF (NUMSEG .GT. 3) GOTO 4900 ADM04010 C ADM04020 C Call REDRAW ALL SEGMENTS to clear msg area ADM04030 CALL GRSGWK(WKID1) ADM04040 CALL GSTXI(2) ADM04050 CALL GTXS(1.0,1.0,33,'No furniture is in the room ') ADM04060 CALL GSTXI(1) ADM04070 MSGFLG = 1 ADM04080 GOTO 1000 ADM04090 4900 CONTINUE ADM04100 C ADM04110 C*** Display msg asking user to pick the furniture to be deleted ADM04120 C Call REDRAW ALL SEGMENTS to clear msg area ADM04130 CALL GRSGWK(WKID1) ADM04140 CALL GTXS(1.0,1.0,33,'Pick the furniture to be removed ') ADM04150 5000 CALL GRQPK(WKID1, 1, STAT, SEGNM, PICKID) ADM04160 IF ((STAT .NE. 1) .OR. (PICKID .GE. 100)) GOTO 5000 ADM04170 C ADM04180 C*** Delete the furniture segment ADM04190 CALL GDSG(SEGNM) ADM04200 C*** Show segment does not exist any more ADM04210 PCKFLG = 0 ADM04220 POSFLG = 0 ADM04230 C ADM04240 5100 CONTINUE ADM04250 C ADM04260 C ****************************************************************** ADM04270 C ***IF EXIT IS CHOSEN * ADM04280 C ****************************************************************** ADM04290 IF (CHCNUM .EQ. 5) GOTO 9999 ADM04300 C ADM04310 C Go back to do another request choice ADM04320 GOTO 1000 ADM04330 C ADM04340 C ADM04350 C******************************************************************** ADM04360 C TERMINATION * ADM04370 C******************************************************************** ADM04380 C ADM04390 C - Deactivate and close the workstation ADM04400 9999 CALL GDAWK (WKID1) ADM04410 CALL GCLWK (WKID1) ADM04420 C ADM04430 C*** CLOSE GKS ADM04440 CALL GCLKS ADM04450 STOP ADM04460 END ADM04470 |
![]() |