GDDM-GKS V1R1 Programming Guide and Reference
GDDM-GKS V1R1 Programming Guide and Reference
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
|
 Copyright IBM Corporation 1990, 2012 |
