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

Go to the previous page Go to the next page



Copyright IBM Corporation 1990, 2012