home *** CD-ROM | disk | FTP | other *** search
/ RISC DISC 2 / RISC_DISC_2.iso / pd_share / program / fortran77_210 / library / f77 / twimp < prev    next >
Encoding:
Text File  |  1992-09-15  |  30.9 KB  |  980 lines
  1.       PROGRAM WimpDemo
  2. C        tests the Wimp library
  3. C        needs 'wimp' and 'utils' libraries
  4. C        the Wimp library is complete, but not all tested
  5. C        the routines which have not been tried are indicated
  6. C        with an '*' before their name in the writeup.
  7. C
  8.       COMMON IPMASK,KOLOR,IWHAND,ICONH,IWSAVE,IBLOCK(128),MBLOC(100)
  9.       COMMON /TESTW/ ITWHAN,ITWT(10),ITEST,IWDEL,MX,MY,IH,II
  10.       DIMENSION ICBLOC(9)
  11.       CHARACTER TITLE*9
  12.       DATA TITLE /'F77 test.'/
  13.       DATA ICBLOC/0,32,-180,196,-132,?I0800B03D,3*0/
  14. C
  15. C                INITIALISE WIMP
  16.       CALL WMPI('TWimp',ITHAND)
  17. C                CREATE WINDOW
  18. C       x,y,width,depth,extx,exty,title,flags
  19. C       extx & exty are total size
  20.       IY=500+RND01()*500
  21.       IWHAND=IWMPCW(0,IY,300,500,500,700,TITLE,?IFF00000F)
  22. C                Create Icon
  23.       ICBLOC(1)=IWHAND
  24.       CALL WMPC2H('Icon test',ICBLOC(7))
  25.       CALL WMPCI(ICBLOC,ICONH)
  26. C                Make up menu
  27.       CALL MKMENU
  28. C                set default colour for circle
  29.       KOLOR=10
  30. C                OPEN WINDOW
  31.       IBLOCK(1)=IWHAND
  32.       CALL WMPGWS(IBLOCK)
  33.       CALL WMPOW(IBLOCK)
  34. C                WIMP POLL
  35.       IPMASK=?I31
  36.       ITEST=0
  37.    10 CALL WMPP(IPMASK,IBLOCK,IREASN)
  38. C       Do drag box requests
  39.       CALL SAVEBX(IBLOCK,IREASN)
  40. C       IREASN set negative if call has been used
  41.       IF(IREASN.LT.0) GO TO 10
  42. C       Do transfer block requests
  43.       IF(ITEST.EQ.26.OR.ITEST.EQ.0) CALL TRBLOC(IREASN,ITHAND)
  44. C       IREASN set negative if call has been used
  45.       IF(IREASN.LT.0) GO TO 10
  46. C       poll with no particular reason
  47.       IF(IREASN.EQ.0) CALL TEST0
  48. C       Redraw window request
  49.       IF(IREASN.EQ.1) CALL REDRAW
  50. C       Open window request
  51.       IF(IREASN.EQ.2) CALL WMPOW(IBLOCK)
  52. C       Close window request
  53.       IF(IREASN.EQ.3) THEN
  54. C          If top window, stop job
  55.         IF(IBLOCK(1).EQ.IWHAND) CALL QUIT
  56. C          otherwise just close window
  57.         CALL WMPCLW(IBLOCK(1))
  58. C          if testing DeleteWindow then do just that!
  59.         IF(IBLOCK(1).EQ.IWDEL) CALL WMPDW(IWDEL)
  60.       ENDIF
  61. C       Mouse click
  62.       IF(IREASN.EQ.6) CALL BUTTON
  63. C       Key pressed
  64.       IF(IREASN.EQ.8) CALL WMPPK(IBLOCK(7))
  65. C       Click over menu
  66.       IF(IREASN.EQ.9) CALL MENU
  67. C       User message
  68.       IF(IREASN.EQ.17.OR.IREASN.EQ.18) THEN
  69. C           requesting close down
  70.         IF(IBLOCK(5).EQ.0) CALL QUIT
  71. C           moving over menu arrow, test Wimp_CreateSubMenuu
  72.         IF(IBLOCK(5).EQ.?I0400C0)
  73.      +       CALL WMPCSM(IBLOCK(6),IBLOCK(7)+128,IBLOCK(8))
  74.       ENDIF
  75.       GO TO 10
  76.       END
  77. C
  78.       BLOCK DATA
  79.       PARAMETER (N3=28)
  80.       CHARACTER*12 TITL3,LIST3
  81.       COMMON /CHTEST/TITL3,LIST3(N3)
  82.       DATA TITL3/'Tests'/,LIST3/'Errors','BaseOfSprite','BlockCopy',
  83.      +'ClaimFreeMem','CommandWindo','CreateSubMen','DeleteIcon  ',
  84.      +'DecodeMenu  ','DeleteWindow','GetCaretPosn','GetWindowInf',
  85.      +'GetWindowOut','PlotIcon    ','PollIdle    ','ReadPalette ',
  86.      +'ReadPixTrans','ReadSysInfo ','SetExtent   ','SetFontCols ',
  87.      +'SetIconState','SetMode     ','SetPalette  ','SetPointerSh',
  88.      +'SpriteOp    ','SlotSize    ','StartTask   ','TransferBloc',
  89.      +'WhichIcon   '/
  90.       END
  91. C
  92.       SUBROUTINE BUTTON
  93.       COMMON IPMASK,KOLOR,IWHAND,ICONH,IWSAVE,IBLOCK(128),MBLOC(100)
  94.       EQUIVALENCE(IBLOCK(1),MOUSEX),(IBLOCK(2),MOUSEY),
  95.      +(IBLOCK(3),IBUTTN),(IBLOCK(4),IWINDO),(IBLOCK(5),ICON)
  96.       COMMON /TESTW/ ITWHAN,ITWT(10),ITEST,IWDEL,MX,MY,IH,II
  97. C        check button type (1:adjust, 2:menu, 4:select)
  98. C            open menu at mouse position
  99.       IF(IBUTTN.EQ.2.AND.IWINDO.EQ.IWHAND)
  100.      +    CALL WMPCM(MBLOC,MOUSEX,MOUSEY)
  101. C            do caret checking
  102.       IF(ITEST.EQ.9.AND.IWINDO.EQ.ITWHAN) CALL CARET
  103.       RETURN
  104.       END
  105. C
  106. C
  107.       SUBROUTINE MENU
  108.       COMMON IPMASK,KOLOR,IWHAND,ICONH,IWSAVE,IBLOCK(128),MBLOC(100)
  109.       COMMON /TESTW/ ITWHAN,ITWT(10),ITEST,IWDEL,MX,MY,IH,II
  110.       DIMENSION MYBLOC(5)
  111. C           called if mouse button is clicked over menu
  112. C
  113. C           first close tests window (if open)
  114.       CALL WMPCLW(ITWHAN)
  115. C           check if second level window
  116.       IF(IBLOCK(2).GE.0)THEN
  117. C           check for 'more tests' in top menu
  118.         IF(IBLOCK(1).EQ.3) THEN
  119. C           do the extra test of type IBLOCK(2)
  120.           CALL TESTS(IBLOCK(2))
  121.         ELSE
  122. C             look at 2nd menu choices here 0=red, 1=Green, 2=Blue
  123.           IF(IBLOCK(2).EQ.0)KOLOR=11
  124.           IF(IBLOCK(2).EQ.1)KOLOR=10
  125.           IF(IBLOCK(2).EQ.2)KOLOR=15
  126. C    now force a redraw use whole window because don't know which bit needed
  127.           CALL WMPFR(IWHAND,0,-700,500,0)
  128.         ENDIF
  129.       ELSE
  130. C              do nothing here if not first menu
  131.         IF(IBLOCK(1).EQ.4) THEN
  132. C              stop job if 5th option selected (starts from 0)
  133.           CALL QUIT
  134.         ELSE
  135. C                Set bit to draw a tick on the 1st menu example
  136.          IF(IBLOCK(1).EQ.0) MBLOC(8)=1-MBLOC(8)
  137.         ENDIF
  138.       ENDIF
  139.       CALL WMPGPI(MYBLOC)
  140. C                   restore menu if 'Adjust' button pressed
  141.       IF(MYBLOC(3).EQ.1) CALL WMPCM(MBLOC,MYBLOC(1),MYBLOC(2))
  142.       RETURN
  143.       END
  144. C
  145.       SUBROUTINE MKMENU
  146.       COMMON IPMASK,KOLOR,IWHAND,ICONH,IWSAVE,IBLOCK(128),MBLOC(100)
  147.       PARAMETER (N3=28)
  148.       CHARACTER*12 TITL3,LIST3
  149.       COMMON /CHTEST/TITL3,LIST3(N3)
  150.       COMMON /TESTW/ ITWHAN,ITWT(10),ITEST,IWDEL,MX,MY,IH,II
  151.       PARAMETER (NMENU=5,N2=3,N4=2)
  152.       DIMENSION MBLOC2(7+6*N2),MBLOC3(7+6*N3),MBLOC4(7+6*N4)
  153.       CHARACTER*12 TITLM,LIST(NMENU),TITL2,LIST2(N2),TITL4,LIST4(N4)
  154.       CHARACTER*13 TWNAME
  155.       DATA TITLM/'Menu'/,LIST/'Example','Circle','save',
  156.      +                        'More Tests','Quit'/
  157.       DATA TITL2/'Colour'/,LIST2/'Red','Green','Blue'/
  158.       DATA TITL4/'SubMenu'/,LIST4/'Item 1','Item 2'/
  159. C                 set up 3rd menu the hard way
  160. C      DATA MBLOC3/0,0,0,?I070207,192,44,0,128,-1,?I07009031,3*0/
  161. C                 set up menu block
  162.       CALL WMPMNU(MBLOC,TITLM,LIST,NMENU)
  163.       CALL WMPMNU(MBLOC2,TITL2,LIST2,N2)
  164. C                 make 2nd menu connected to 2nd item, 'Circle' in 1st list
  165.       MBLOC(7+2+6*1)=LOC(MBLOC2)
  166. C                   set up drag box window
  167.       CALL SAVEMN(?I0FFF,IWSAVE)
  168. C                  connect to menu
  169.       MBLOC(9+6*2)=IWSAVE
  170. C                  make up tests menu
  171.       CALL WMPMNU(MBLOC3,TITL3,LIST3,N3)
  172. C                  connect to main menu
  173.       MBLOC(9+6*3)=LOC(MBLOC3(1))
  174. C                  make up test sub-menu
  175.       CALL WMPMNU(MBLOC4,TITL4,LIST4,N4)
  176. C                  connect to menu 3
  177.       MBLOC3(9+6*5)=LOC(MBLOC4(1))
  178. C                  set 'generate message' flag
  179.       MBLOC3(8+6*5)=8
  180. C                  load test window template
  181.       CALL WMPOT('f77.TWTemplate')
  182.       IP=0
  183.       TWNAME='DelTest'//?H00
  184.       LT=10
  185. C
  186.       CALL WMPLT(IBLOCK,ITWT,LT,-1,TWNAME,IP)
  187. C                   create window to delete
  188.       CALL WMPCRW(IBLOCK,IWDEL)
  189. C                   create test window
  190.       IP=0
  191.       TWNAME='TWimp'//?H00
  192.       LT=10
  193. C
  194.       CALL WMPLT(IBLOCK,ITWT,LT,-1,TWNAME,IP)
  195. C                   create test window
  196.       CALL WMPCRW(IBLOCK,ITWHAN)
  197.       CALL WMPCT
  198.       RETURN
  199.       END
  200. C
  201.       SUBROUTINE SAVEBX(JBLOC,IREASN)
  202. C    two routines for saving files from menu windows using DragBoxes
  203. C
  204. C       firstly:
  205. C
  206. C  SAVEMN(ITYPE,IWINDO) creates the window containing a sprite, filename
  207. C  OK box, to be attached to a menu which includes a 'Save' option.
  208. C  It returns IWINDO, the handle of the created window.
  209. C  It must be given ITYPE, the file type to be saved.
  210. C         at the moment ITYPE can be either ?I0FFF (text) or ?I0AFF (draw)
  211. C         others can be included by incrementing NTYPES and the associated
  212. C         DATA statements below
  213. C
  214. C       then the work is done by:
  215. C
  216. C  SAVEBX(JBLOC,IREASN) called in the Wimp_Poll loop
  217. C    JBLOC and IREASN are the WimpPoll block and reason code
  218. C    IREASN is returned negative if SAVEBX has used this poll
  219. C
  220. C      the user must also supply the following routine:
  221. C
  222. C  SAVEFL(IERR) user routine to save the file to '<F77$File>' which is a
  223. C    system alias for the name in the icon of the 'save' window. This is to
  224. C    get round the bug in Fortran77 where file names are truncated to 30
  225. C    characters in the OPEN statement.
  226. C         returns IERR=0 if OK;
  227. C if the save failed, it returns IERR<>0 when the file must not be written
  228. C or it must be deleted if one has been written.
  229. C
  230.       DIMENSION JBLOC(*)
  231.       DIMENSION IBLOC(22),IREGS(0:7)
  232.       EQUIVALENCE(IREGS(2),ITYPS)
  233.       PARAMETER (NTYPES=2)
  234.       CHARACTER DUMMY*1,FTYPE*9,VALID*4,FNAME*100,FOK*3
  235.       CHARACTER*11 OLDFNM
  236.       CHARACTER*4 TYPE(NTYPES),LTYP(NTYPES)*3
  237.       LOGICAL MYDRAG
  238.       DIMENSION JTYP(NTYPES)
  239.       DATA VALID/'A~ .'/,FOK/'OK.'/,DUMMY/'.'/
  240.       DATA TYPE/'Text','Draw'/
  241.       DATA JTYP/?I0FFF,?I0AFF/
  242.       DATA LTYP/  'fff', 'aff'/
  243.       DATA IBLOC/0,-164,264,0,0,0,-1,?I84000012,?I01070207,?I020103,
  244.      +0,-164,264,0,?I3D,?I3000,0,0,?I65766153,?I3A736120,0,0/
  245.       DATA IREGS/18,7*0/
  246. C
  247. C           stop drag from other parts of this program
  248.       IF(IREASN.NE.7) MYDRAG=.FALSE.
  249. C
  250.       IF((IREASN.EQ.17.OR.IREASN.EQ.18).AND.JBLOC(5).EQ.2) THEN
  251. C
  252. C  'User message of type 2' (Wimp_Poll reason 17 or 18, JBLOC(5) is type)
  253. C       this is the filer replying to request to save file
  254. C       JBLOC contains the reply from the filer
  255. C              get file name into FNAME
  256.         CALL WMPH2C(JBLOC(12),FNAME,L)
  257. C                close menu
  258.         CALL WMPCM(-1,0,0)
  259. C                set up alias for name
  260.         CALL OSCLI('Set F77$File '//FNAME(1:L))
  261. C                write the file
  262.         CALL SAVEFL(IERR)
  263. C                set file type with OS_File 18
  264.         IF(IERR.EQ.0) CALL SWIF77(8,IREGS,IFLAG)
  265. C                reset filename if not confirmed
  266.         IF(JBLOC(10).LE.-1) FNAME=OLDFNM
  267. C          send data-load message to filer
  268.         JBLOC(4)=JBLOC(3)
  269.         JBLOC(5)=3
  270.         JBLOC(1)=64
  271.         CALL WMPSMG(18,JBLOC,JBLOC(6),JBLOC(7))
  272. C          set 'used' flag
  273.         IREASN=-1
  274.         RETURN
  275.       ENDIF
  276. C
  277. C         is this mouse click over 'save' window
  278.       IF(IREASN.EQ.6.AND.JBLOC(4).EQ.IWSAVE) THEN
  279. C          set 'used' flag
  280.         IREASN=-1
  281. C             click over 'OK' icon, go save file...
  282.         IF(JBLOC(5).EQ.ICOK) GO TO 300
  283. C
  284.         IF(JBLOC(5).EQ.ICSPRT .AND. IAND(JBLOC(3),?I50).GT.0) THEN
  285. C              drag initiated with mouse
  286. C              set up drag box attached to mouse
  287.           IBLOC(1)=IWSAVE
  288. C             Find coordinates of save window
  289.           CALL WMPGWS(IBLOC)
  290.           IX0=IBLOC(2)-IBLOC(6)
  291.           IY0=IBLOC(5)-IBLOC(7)
  292.           IBLOC(2)=ICSPRT
  293. C             Find coordinates of sprite icon
  294.           CALL WMPGIS(IBLOC)
  295. C             Set up for drag
  296.           IBLOC(1)=IWSAVE
  297. C             Drag type 5
  298.           IBLOC(2)=5
  299. C             coordinates of sprite boundary
  300.           IBLOC(3)=IX0+IBLOC(3)
  301.           IBLOC(4)=IY0+IBLOC(4)
  302.           IBLOC(5)=IX0+IBLOC(5)
  303.           IBLOC(6)=IY0+IBLOC(6)
  304. C             bounds for dragging to
  305.           IBLOC(7)=0
  306.           IBLOC(8)=0
  307.           IBLOC(9)=99999
  308.           IBLOC(10)=99999
  309. C             set MYDRAG to allow its detection
  310.           MYDRAG=.TRUE.
  311. C             initiate drag
  312.           CALL WMPDB(IBLOC)
  313.         ENDIF
  314.         RETURN
  315.       ENDIF
  316. C
  317. C             is key pressed over save window?
  318.       IF(IREASN.EQ.8.AND.JBLOC(1).EQ.IWSAVE) THEN
  319. C     (Wimp_Poll reason 8, window handle in JBLOC(1), Key value in JBLOC(7))
  320. C            set 'used' flag
  321.         IREASN=-1
  322. C              accept <CR> only
  323.         IF(JBLOC(7).EQ.13) GO TO 300
  324. C            otherwise give back to Wimp
  325.         CALL WMPPK(JBLOC(7))
  326.         RETURN
  327.       ENDIF
  328. C
  329.       IF(IREASN.EQ.7.AND.MYDRAG) THEN
  330. C      IF(IREASN.EQ.7) THEN
  331. C      drag finished (reason 7 from Wimp_Poll)
  332. C            initiate save dialogue
  333. C
  334. C            set 'used' flag
  335.         IREASN=-1
  336. C            find where we are
  337.         CALL WMPGPI(IBLOC)
  338. C            check we are over a window
  339.         IF(IBLOC(4).LT.0) RETURN
  340. C            set up datasave message
  341. C
  342. C            Window & icon handles
  343.         IBLOC(6)=IBLOC(4)
  344.         IBLOC(7)=IBLOC(5)
  345. C             coordinates
  346.         IBLOC(8)=IBLOC(1)
  347.         IBLOC(9)=IBLOC(2)
  348. C              size of file (a guess only!!!)
  349.         IBLOC(10)=9999
  350. C              file type
  351.         IBLOC(11)=ITYPS
  352. C              null terminated file name
  353.         L=INDEX(FNAME,CHAR(0))
  354.         DO 210 I=L-1,1,-1
  355.           IF(FNAME(I:I).EQ.'.') GO TO 220
  356.   210   CONTINUE
  357.         I=0
  358.   220   IF(L-I.LT.2 .OR. L-I.GT.11) THEN
  359.           CALL WMPRE(20,'Problem in file name length calculation',
  360.      +    1,'Drag File',IR)
  361.           RETURN
  362.         ENDIF
  363.         OLDFNM=FNAME(I+1:L)
  364.         CALL WMPC2H(FNAME(I+1:L-1),IBLOC(12))
  365. C              block length in bytes & dummy reference #
  366.         IBLOC(1)=64
  367.         IBLOC(4)=0
  368. C              action (1 = save)
  369.         IBLOC(5)=1
  370. C              now send message
  371.         CALL WMPSMG(17,IBLOC,IBLOC(6),IBLOC(7))
  372.       ENDIF
  373.       RETURN
  374. C
  375. C           file name FNAME entered by hand, save the file
  376.   300 IF(INDEX(FNAME,'$.').EQ.0) THEN
  377.         CALL WMPRE(20,'Please set up the complete file and path name'
  378.      +  ,1,'Drag File',IR)
  379.       ELSE
  380. C                close menu
  381.         CALL WMPCM(-1,0,0)
  382. C                set up alias for name
  383.         L=INDEX(FNAME,CHAR(0))-1
  384.         CALL OSCLI('Set F77$File '//FNAME(1:L))
  385. C                write the file
  386.         CALL SAVEFL(IERR)
  387. C            set file type with OS_File 18
  388.         IF(IERR.EQ.0) CALL SWIF77(8,IREGS,IFLAG)
  389.       ENDIF
  390.       RETURN
  391. C
  392. C          SAVEMN(ITYPE,IWINDO) sets up a save window with handle IWINDO
  393. C                               for files of type ITYPE
  394. C
  395.       ENTRY SAVEMN(ITYPE,IWINDO)
  396. C           set up file name location for OS_File
  397.       IREGS(1)=LOCC(FNAME)
  398. C           find file type in list
  399.       ITYPS=ITYPE
  400.       DO 10 IT=1,NTYPES
  401.         IF(ITYPE.EQ.JTYP(IT)) GO TO 20
  402.    10 CONTINUE
  403.       IWINDO=-1
  404.       RETURN
  405. C            construct Wimp sprite name
  406.    20 FTYPE='file_'//LTYP(IT)
  407. C                  make window
  408.       CALL WMPCRW(IBLOC,IWSAVE)
  409.       IWINDO=IWSAVE
  410. C                  make file sprite
  411.       ICSPRT=IWMPCI(IWSAVE,100,-92,68,68,?I6102,FTYPE,DUMMY)
  412. C                  make file name
  413.       FNAME=TYPE(IT)//'File'//CHAR(0)
  414.       ICNAME=IWMPCI(IWSAVE,8,-156,192,48,?I0700F12D,FNAME,VALID)
  415. C                  make 'OK' box
  416.       ICOK=IWMPCI(IWSAVE,208,-156,48,48,?IC701903D,FOK,DUMMY)
  417.       RETURN
  418.       END
  419. C
  420.       SUBROUTINE SAVEFL(IERR)
  421.       IERR=0
  422.       OPEN(20,FILE='<F77$File>',FORM='FORMATTED',ERR=900)
  423.       WRITE(20,101,ERR=900)
  424.   101 FORMAT('Here is a little test file'/
  425.      +       'Written to the file:'/)
  426.       GO TO 999
  427.   900 IERR=1
  428.   999 CLOSE(20)
  429.       CALL OSCLI('SHOW F77$File { >> <F77$File> }')
  430.       RETURN
  431.       END
  432. C
  433.       SUBROUTINE QUIT
  434.       CALL WMPCD
  435.       STOP
  436.       END
  437. C
  438.       SUBROUTINE REDRAW
  439.       COMMON IPMASK,KOLOR,IWHAND,ICONH,IWSAVE,IBLOCK(128),MBLOC(100)
  440.       COMMON /TESTW/ ITWHAN,ITWT(10),ITEST,IWDEL,MX,MY,IH,II
  441. C      IBLOCK(1)=IWHAND
  442.       CALL WMPRW(IBLOCK,MORE)
  443.       IF(MORE.EQ.0) RETURN
  444.    10 IX0=IBLOCK(2)-IBLOCK(6)
  445.       IY0=IBLOCK(5)-IBLOCK(7)
  446.       IF(IBLOCK(1).EQ.IWHAND) CALL DRAWW(IX0,IY0)
  447.       IF(IBLOCK(1).EQ.ITWHAN) CALL DRAWT(IX0,IY0)
  448.       IF(IBLOCK(1).EQ.IWDEL) CALL DRAWD(IX0,IY0)
  449.       CALL WMPGR(IBLOCK,MORE)
  450.       IF(MORE.NE.0) GO TO 10
  451.       IF(ITEST.EQ.13) CALL POLLID
  452.       RETURN
  453.       END
  454. C
  455.       SUBROUTINE DRAWW(IX0,IY0)
  456.       COMMON IPMASK,KOLOR,IWHAND,ICONH,IWSAVE,IBLOCK(128),MBLOC(100)
  457.       CALL WMPSC(0,11,0)
  458. C      print some text at 0,-40 in colour 11
  459.       CALL WMPTXT(IX0,IY0-40,'Try clicking menu')
  460.       CALL WMPTXT(IX0,IY0-80,'over this window')
  461.       CALL WMPSC(0,KOLOR,0)
  462. C      Plot disc at 200,-400, radius 70, in colour KOLOR
  463.       PRINT 101,25,4,IX0+200,IY0-400,25,153,0,70
  464.   101 FORMAT($,2A1,2A2,2A1,2A2)
  465.       RETURN
  466.       END
  467. C
  468.       SUBROUTINE TESTS(ITT)
  469.       COMMON IPMASK,KOLOR,IWHAND,ICONH,IWSAVE,IBLOCK(128),MBLOC(100)
  470.       DIMENSION KPOINT(9),ICON1(9),IRED(20),IGREEN(20),IBLUE(20)
  471.       PARAMETER (N3=28)
  472.       CHARACTER*12 TITL3,LIST3
  473.       COMMON /CHTEST/TITL3,LIST3(N3)
  474.       COMMON /TESTW/ ITWHAN,ITWT(10),ITEST,IWDEL,MX,MY,IH,II
  475.       DATA MODES /27/, KPFLAG /1/, IHANDL/-1/
  476.       DATA ICON1/0,128,-384,384,-128,?IFB00603D,3*0/
  477.       DATA KPOINT/9*?I55555555/
  478.  
  479. C           do test ITT
  480. C
  481.       ITEST=ITT
  482.       IF(ITEST.EQ.0) THEN
  483. C            ITEST=0: test error return capability
  484.         CALL WMPOT('$')
  485.         RETURN
  486.       ENDIF
  487.       IF(ITEST.EQ.4) THEN
  488. C            test Wimp_CommandWindow
  489.         CALL WMPCOW(LOCC('Testing Wimp_CommandWindow'//?H00))
  490.         PRINT*,' Just a few words in this text window'
  491.         CALL WMPTC(11)
  492.         PRINT *,' and some more in RED'
  493.         CALL WMPTC(13)
  494.         CALL WMPCOW(0)
  495.         RETURN
  496.       ENDIF
  497. C        create submenu activated by moving over arrow
  498.       IF(ITEST.EQ.5) RETURN
  499. C        delete the icon
  500.       IF(ITEST.EQ.6) THEN
  501.         IBLOCK(1)=IWHAND
  502.         IBLOCK(2)=ICONH
  503.         CALL WMPDI(IBLOCK)
  504.         CALL WMPFR(IWHAND,0,-700,500,0)
  505.         RETURN
  506.       ENDIF
  507.       MX=0
  508.       MY=0
  509.       IH=0
  510.       II=0
  511.       IF(ITEST.EQ.10) THEN
  512. C            get window information (II = # icons)
  513.         IBLOCK(1)=IWHAND
  514.         CALL WMPGWI(IBLOCK)
  515.         MX=IBLOCK(14)-IBLOCK(12)
  516.         MY=IBLOCK(15)-IBLOCK(13)
  517.         II=IBLOCK(23)
  518.       ENDIF
  519.       IF(ITEST.EQ.11) THEN
  520. C            get window outline
  521.         IBLOCK(1)=IWHAND
  522.         CALL WMPGWI(IBLOCK)
  523.         MX=IBLOCK(2)
  524.         MY=IBLOCK(3)
  525.         IH=IBLOCK(4)
  526.         II=IBLOCK(5)
  527.       ENDIF
  528. C            set window extent bigger in y
  529.       IF(ITEST.EQ.17) THEN
  530.         IBLOCK(1)=0
  531.         IBLOCK(2)=-768
  532.         IBLOCK(3)=512
  533.         IBLOCK(4)=0
  534.         CALL WMPSE(ITWHAN,IBLOCK)
  535.       ENDIF
  536. C            toggle icon colour
  537.       IF(ITEST.EQ.19) THEN
  538.         IBLOCK(1)=IWHAND
  539.         IBLOCK(2)=ICONH
  540.         IBLOCK(3)=?IFF000000
  541.         IBLOCK(4)=0
  542.         CALL WMPSIS(IBLOCK)
  543.         CALL WMPFR(IWHAND,0,-700,500,0)
  544.       ENDIF
  545. C           toggle mode!
  546.       IF(ITEST.EQ.20) THEN
  547.         IF(MODES.EQ.27) THEN
  548.           MODES=15
  549.         ELSE
  550.           MODES=27
  551.         ENDIF
  552.         CALL WMPSMD(MODES)
  553.       ENDIF
  554. C          toggle background colour
  555.       IF(ITEST.EQ.21) THEN
  556. C          get current palette
  557.         CALL WMPRP(IRED,IGREEN,IBLUE)
  558. C            change colour 4 (wimp background)
  559.         IF(IBLUE(5).EQ.112) THEN
  560.           IBLUE(5)=0
  561.           IGREEN(5)=80
  562.         ELSE
  563.           IBLUE(5)=112
  564.           IGREEN(5)=112
  565.         ENDIF
  566. C           reset palette
  567.         CALL WMPSP(IRED,IGREEN,IBLUE)
  568.       ENDIF
  569. C            set pointer shape
  570.       IF(ITEST.EQ.22) THEN
  571.         IF(KPFLAG.EQ.1) THEN
  572.           KPFLAG=2
  573.           CALL WMPSPS(2,LOC(KPOINT),12,12,6,6)
  574.         ELSE
  575.           KPFLAG=1
  576.           CALL WMPSPS(1,-1,0,0,0,0)
  577.         ENDIF
  578.       ENDIF
  579. C          find slot sizes
  580.       IF(ITEST.EQ.24) CALL WMPSS(-1,-1,MX,MY,II)
  581. C             start another task
  582.       IF(ITEST.EQ.25) CALL WMPST('RUN aif.TWimp')
  583. C            transfer block
  584.       IF(ITEST.EQ.26) THEN
  585. C            first start another task to drag the block to
  586.         CALL WMPST('RUN aif.TWimp')
  587. C            set up the block icon
  588.         ICON1(1)=ITWHAN
  589.         CALL WMPCI(ICON1,IHANDL)
  590.       ELSE
  591.         IF(IHANDL.GE.0) THEN
  592. C            delete the block icon
  593.           IBLOCK(1)=ITWHAN
  594.           IBLOCK(2)=IHANDL
  595.           IHANDL=-1
  596.           CALL WMPDI(IBLOCK)
  597.         ENDIF
  598.       ENDIF
  599. C             find inverted icons
  600.       IF(ITEST.EQ.27) CALL WMPWI(IWHAND,MX,?I200000,?I200000)
  601. C
  602.       CALL WMPC2H('Testing '//LIST3(ITEST+1),ITWT)
  603.       IBLOCK(1)=ITWHAN
  604.       IF(ITEST.EQ.8) IBLOCK(1)=IWDEL
  605.       CALL WMPGWS(IBLOCK)
  606.       CALL WMPOW(IBLOCK)
  607.       RETURN
  608.       END
  609. C
  610.       SUBROUTINE DRAWD(IX0,IY0)
  611.       COMMON IPMASK,KOLOR,IWHAND,ICONH,IWSAVE,IBLOCK(128),MBLOC(100)
  612.       COMMON /TESTW/ ITWHAN,ITWT(10),ITEST,IWDEL,MX,MY,IH,II
  613.       CHARACTER*32 STRING
  614. C         messages for delete window test
  615.       WRITE(STRING,101)'Close this window, then'
  616.       CALL WMPTXT(IX0+32,IY0-40,STRING)
  617.       WRITE(STRING,101)'it will be deleted and'
  618.       CALL WMPTXT(IX0+32,IY0-100,STRING)
  619.       WRITE(STRING,101)'next time you''ll get an error'
  620.       CALL WMPTXT(IX0+32,IY0-160,STRING)
  621.       RETURN
  622.   101 FORMAT(A)
  623.       END
  624. C
  625.       SUBROUTINE DRAWT(IX0,IY0)
  626.       COMMON IPMASK,KOLOR,IWHAND,ICONH,IWSAVE,IBLOCK(128),MBLOC(100)
  627.       COMMON /TESTW/ ITWHAN,ITWT(10),ITEST,IWDEL,MX,MY,IH,II
  628.       CHARACTER*32 STRING
  629.       DIMENSION LIST(3),ICONB(8),KPAL(20),IPAR(3:7),MULT(4)
  630.       DIMENSION IRED(20),IGREEN(20),IBLUE(20)
  631.       DATA MULT/1,2,1,1/
  632.       DATA LIST/3,7,-1/
  633.       DATA ICONB/32,-96,256,-32,?IFB00003D,?I746F6C50,?I6E6F6349,0/
  634. C                                            'Plot'  ,  'Icon'  ,0/
  635.       GO TO (10, 20, 30, 40, 50, 60, 70, 80, 90,100,
  636.      +      110,120,130,140,150,160,170,180,190,200,
  637.      +      210,220,230,240,250,260,270),ABS(ITEST)
  638. C            testing BaseOfSprites
  639.    10 CALL WMPBOS(IROM,IRMA)
  640. C         print results
  641.       J=(IROM-LOC(IBLOCK))/4+1
  642.       WRITE(STRING,102)IBLOCK(J),IBLOCK(J+1)
  643.       CALL WMPTXT(IX0+32,IY0-40,'ROM sprite block length')
  644.       CALL WMPTXT(IX0+32,IY0-98,STRING(1:6)//
  645.      +', # sprites '//STRING(7:12))
  646.       WRITE(STRING,101)'RMA sprites at ',IRMA
  647.   101 FORMAT(A,Z8)
  648.       CALL WMPTXT(IX0+32,IY0-146,STRING)
  649.       RETURN
  650. C           testing BlockCopy
  651.    20 CALL WMPTXT(IX0+32,IY0-40,'Copy this text down lower')
  652. C           allow general polling
  653.       IPMASK=0
  654.       RETURN
  655.    30 CALL WMPTXT(IX0+32,IY0-40,'Sorry, this can not be done')
  656.       CALL WMPTXT(IX0+32,IY0-88,'with Fortran; it needs to')
  657.       CALL WMPTXT(IX0+32,IY0-136,'be in SVC mode')
  658.       RETURN
  659.    40 CONTINUE
  660.    50 CONTINUE
  661.    60 CONTINUE
  662.       RETURN
  663. C          testing DecodeMenu
  664.    70 CALL WMPDM(MBLOC,LIST,STRING,LEN)
  665.       CALL WMPTXT(IX0+32,IY0-40,'This menu string is:')
  666.       CALL WMPTXT(IX0+32,IY0-100,STRING(1:LEN))
  667.       RETURN
  668.    80 RETURN
  669. C          Testing GetCaretPosition
  670.    90 CALL WMPTXT(IX0+32,IY0-32,'Click over this window to get')
  671.       CALL WMPTXT(IX0+32,IY0-96,'the caret and find its values')
  672.       CALL WMPTXT(IX0+32,IY0-288,'x,y =')
  673.       CALL WMPTXT(IX0+32,IY0-352,'h,i =')
  674.       WRITE (STRING,102)MX,MY
  675.   102 FORMAT(3I6)
  676.       CALL WMPTXT(IX0+144,IY0-288,STRING)
  677.       WRITE (STRING,102)IH,II
  678.       CALL WMPTXT(IX0+144,IY0-352,STRING)
  679.       RETURN
  680. C          Testing GetWindowInfo
  681.   100 WRITE (STRING,102)MX,MY
  682.       CALL WMPTXT(IX0+32,IY0-32,'Size of main window')
  683.       CALL WMPTXT(IX0+32,IY0-96,'work area is:')
  684.       CALL WMPTXT(IX0+256,IY0-96,STRING)
  685.       WRITE (STRING,102)II
  686.       CALL WMPTXT(IX0,IY0-192,STRING(1:7)//'icons')
  687.       RETURN
  688.   110 WRITE (STRING,102)MX,MY
  689.       WRITE (STRING(13:24),102)IH,II
  690.       CALL WMPTXT(IX0+32,IY0-32,'Main window is from')
  691.       CALL WMPTXT(IX0+32,IY0-96,STRING(1:12)//' to '//STRING(13:24))
  692.       RETURN
  693. C          testing plot icon
  694.   120 CALL WMPPLI(ICONB)
  695.       RETURN
  696. C          testing Poll Idle
  697.   130 CALL WMPTXT(IX0+32,IY0-32,'beep every 1 second')
  698.       CALL WMPTXT(IX0+32,IY0-96,'click mouse to stop')
  699.       RETURN
  700. C          read palette
  701.   140 CALL WMPRP(IRED,IGREEN,IBLUE)
  702.       DO 142 I=1,10
  703.       WRITE(STRING,144)I-1,IRED(I),IGREEN(I),IBLUE(I),
  704.      +I+9,IRED(I+10),IGREEN(I+10),IBLUE(I+10)
  705.       CALL WMPTXT(IX0+16,IY0-48*I,STRING)
  706.   142 CONTINUE
  707.   144 FORMAT(I1,3I4,I5,3I4)
  708.       RETURN
  709. C          read pix trans of textfile sprite
  710.   150 CALL WMPRPT(0,0,'file_fff',MX,KPAL)
  711.       WRITE(STRING,102)MX,MY
  712.       CALL WMPTXT(IX0+32,IY0-48,'mult factors'//STRING)
  713.       WRITE(STRING,102)IH,II
  714.       CALL WMPTXT(IX0+32,IY0-96,'div  factors'//STRING)
  715.       L=1
  716.       DO 156 I=1,4
  717.       DO 154 J=0,-24,-8
  718.       WRITE(STRING(L:L+1),152)IAND(255,ISHFT(KPAL(I),J))
  719.   152 FORMAT(Z2)
  720.   154 L=L+2
  721.   156 CONTINUE
  722.       CALL WMPTXT(IX0+32,IY0-144,'colour translation:')
  723.       CALL WMPTXT(IX0,IY0-192,STRING)
  724.       RETURN
  725. C          read system info
  726.   160 CALL WMPRSI(0,II)
  727.       WRITE (STRING,102)II
  728.       CALL WMPTXT(IX0+32,IY0-48,'# active tasks'//STRING)
  729.       RETURN
  730.   170 CALL WMPTXT(IX0+32,IY0-128,'window should be')
  731.       CALL WMPTXT(IX0+32,IY0-192,'extendable in Y')
  732.       RETURN
  733.   180 CALL FONTCL(IX0,IY0)
  734.       RETURN
  735.   190 CALL WMPTXT(IX0+32,IY0-40,'Toggle icon colours')
  736.       RETURN
  737.   200 CALL WMPTXT(IX0+32,IY0-40,'Toggle mode')
  738.       RETURN
  739.   210 CALL WMPTXT(IX0+32,IY0-40,'Toggle background colour')
  740.       RETURN
  741.   220 CALL WMPTXT(IX0+32,IY0-40,'Toggle pointer shape')
  742.       RETURN
  743. C           plot a sprite
  744.   230 IPAR(3)=IX0+256
  745.       IPAR(4)=IY0-256
  746.       IPAR(5)=0
  747.       IPAR(6)=LOC(MULT)
  748.       IPAR(7)=0
  749.       CALL WMPSO(52,'file_fff',IPAR)
  750.       RETURN
  751.   240 WRITE(STRING,102)MX/1024,MY/1024,II/1024
  752.       CALL WMPTXT(IX0+32,IY0- 40,'current slot:'//STRING( 1: 6)//'K')
  753.       CALL WMPTXT(IX0+32,IY0-120,'   next slot:'//STRING( 7:12)//'K')
  754.       CALL WMPTXT(IX0+32,IY0-200,'   free pool:'//STRING(13:18)//'K')
  755.       RETURN
  756.   250 CALL WMPTXT(IX0+32,IY0-40,'Start another TWimp')
  757.       CALL WMPTXT(IX0+32,IY0-96,'Please delete it!')
  758.       RETURN
  759.   260 IF(ITEST.GT.0) THEN
  760.         CALL WMPTXT(IX0+32,IY0-40,'Please drag the block below')
  761.         CALL WMPTXT(IX0+32,IY0-88,'to the new TWimp job')
  762.       ELSE
  763.         WRITE(STRING,102)II
  764.         CALL WMPTXT(IX0+32,IY0-40,'Drag of block to the new job')
  765.         CALL WMPTXT(IX0+32,IY0-88,'is complete.')
  766.         CALL WMPTXT(IX0+32,IY0-136,'difference ='//STRING(1:6))
  767.       ENDIF
  768.       RETURN
  769.   270 IF(MX.GE.0) THEN
  770.         CALL WMPTXT(IX0+32,IY0-40,'Icon is inverted')
  771.       ELSE
  772.         CALL WMPTXT(IX0+32,IY0-40,'Icon is not inverted')
  773.       ENDIF
  774.       RETURN
  775.       END
  776. C
  777.       SUBROUTINE TEST0
  778.       COMMON IPMASK,KOLOR,IWHAND,ICONH,IWSAVE,IBLOCK(128),MBLOC(100)
  779.       COMMON /TESTW/ ITWHAN,ITWT(10),ITEST,IWDEL,MX,MY,IH,II
  780.       EXTERNAL SUBFM
  781. C             tests using general poll
  782.       IF(ITEST.EQ.2) THEN
  783. C             test block copy
  784.         CALL WMPBC(ITWHAN,32,-80,480,-40,64,-300)
  785.       ENDIF
  786. C             stop general poll
  787.       IPMASK=?I31
  788.       RETURN
  789.       END
  790. C
  791.       SUBROUTINE CARET
  792.       COMMON IPMASK,KOLOR,IWHAND,ICONH,IWSAVE,IBLOCK(128),MBLOC(100)
  793.       COMMON /TESTW/ ITWHAN,ITWT(10),ITEST,IWDEL,MX,MY,IH,II
  794. C              get pointer screen coordinates
  795.       MX=IBLOCK(1)
  796.       MY=IBLOCK(2)
  797. C              get window coordinates
  798.       IBLOCK(1)=ITWHAN
  799.       CALL WMPGWS(IBLOCK)
  800. C              get mouse coordinates in window
  801.       MX=MX-IBLOCK(2)+IBLOCK(6)
  802.       MY=MY-IBLOCK(5)+IBLOCK(7)
  803. C              move caret to pointer position
  804.       CALL WMPSCP(ITWHAN,-1,MX,MY,64,0)
  805. C              get caret position
  806.       CALL WMPGCP(IBLOCK)
  807. C              print it out
  808.       MX=IBLOCK(3)
  809.       MY=IBLOCK(4)
  810.       IH=IBLOCK(5)
  811.       II=IBLOCK(6)
  812.       CALL WMPFR(ITWHAN,0,-512,512,0)
  813.       RETURN
  814.       END
  815. C
  816.       SUBROUTINE POLLID
  817.       COMMON IPMASK,KOLOR,IWHAND,ICONH,IWSAVE,IBLOCK(128),MBLOC(100)
  818.       COMMON /TESTW/ ITWHAN,ITWT(10),ITEST,IWDEL,MX,MY,IH,II
  819. C              do poll idle loop every 100 centisec
  820.    10 CALL WMPPOI(?I0E1932,IBLOCK,IREASN,100)
  821.       IF(IREASN.EQ.0) PRINT 101,7
  822.       IF(IREASN.NE.6) GO TO 10
  823.   101 FORMAT($,A1)
  824. C             stop it coming back again if the window is redrawn
  825.       ITEST=-13
  826.       RETURN
  827.       END
  828. C
  829.       SUBROUTINE FONTCL(IX0,IY0)
  830. C         test changing colours of anti-aliased fonts
  831.       DIMENSION IREGS(0:7)
  832.       LOGICAL SWIF77
  833.       IREGS(1)=LOCC('Trinity.Medium'//?H00)
  834.       IREGS(2)=640
  835.       IREGS(3)=640
  836.       IREGS(4)=0
  837.       IREGS(5)=0
  838. C              find font
  839.       IF(SWIF77(?I040081,IREGS,IFLAG)) STOP'fonterr'
  840.       IH=IREGS(0)
  841.       IREGS(1)=LOCC('Anti-Alias'//?H00)
  842.       IREGS(2)=16
  843.       IREGS(3)=IX0+32
  844.       IREGS(4)=IY0-128  
  845. C             change font colours
  846.       CALL WMPSFC(8,15)
  847. C             paint text
  848.       IF(SWIF77(?I040086,IREGS,IFLAG)) STOP'painterr'
  849. C             restore font colours
  850.       CALL WMPSFC(0,7)
  851.       IREGS(4)=IY0-384
  852.       IF(SWIF77(?I040086,IREGS,IFLAG)) STOP'painterr'
  853.       IREGS(0)=IH
  854. C            lose font
  855.       IF(SWIF77(?I040082,IREGS,IFLAG)) STOP'losefont'
  856.       RETURN
  857.       END
  858.       SUBROUTINE TRBLOC(IREASN,ITHAND)
  859.       COMMON IPMASK,KOLOR,IWHAND,ICONH,IWSAVE,IBLOCK(128),MBLOC(100)
  860.       COMMON /TESTW/ ITWHAN,ITWT(10),ITEST,IWDEL,MX,MY,IH,II
  861.       PARAMETER (N3=28)
  862.       CHARACTER*12 TITL3,LIST3
  863.       COMMON /CHTEST/TITL3,LIST3(N3)
  864.       DIMENSION IFETCH(8),ISEND(8)
  865.       DATA ISEND/1,2,3,4,5,6,7,8/
  866. C
  867. C            all the logic used to drag a block of data from
  868. C            one task to another
  869. C
  870.       IF(IREASN.EQ.6 .AND. IBLOCK(4).EQ.ITWHAN .AND.
  871.      +IBLOCK(5).EQ.0 .AND. IAND(IBLOCK(3),?I50).GT.0) THEN
  872. C              drag initiated with mouse
  873. C             set 'used' flag
  874.         IREASN=-1
  875. C              set up drag box attached to mouse
  876.         IBLOCK(1)=ITWHAN
  877. C             Find coordinates of save window
  878.         CALL WMPGWS(IBLOCK)
  879.         IX0=IBLOCK(2)-IBLOCK(6)
  880.         IY0=IBLOCK(5)-IBLOCK(7)
  881. C             Set up for drag
  882.         IBLOCK(1)=IWSAVE
  883. C             Drag type 5
  884.         IBLOCK(2)=5
  885. C             coordinates of sprite boundary
  886.         IBLOCK(3)=IX0+128
  887.         IBLOCK(4)=IY0-384
  888.         IBLOCK(5)=IBLOCK(3)+256
  889.         IBLOCK(6)=IBLOCK(4)+256
  890. C             bounds for dragging to
  891.         IBLOCK(7)=0
  892.         IBLOCK(8)=0
  893.         IBLOCK(9)=99999
  894.         IBLOCK(10)=99999
  895. C             initiate drag
  896.         CALL WMPDB(IBLOCK)
  897.         RETURN
  898.       ENDIF
  899.       IF(IREASN.EQ.7) THEN
  900. C      drag finished (reason 7 from Wimp_Poll)
  901. C            initiate save dialogue
  902. C
  903. C            set 'used' flag
  904.         IREASN=-1
  905. C            find where we are
  906.         CALL WMPGPI(IBLOCK)
  907. C            check we are over a window
  908.         IF(IBLOCK(4).LT.0) RETURN
  909. C            set up datasave message
  910. C
  911. C            Window & icon handles
  912.         IBLOCK(6)=IBLOCK(4)
  913.         IBLOCK(7)=IBLOCK(5)
  914. C             coordinates
  915.         IBLOCK(8)=IBLOCK(1)
  916.         IBLOCK(9)=IBLOCK(2)
  917. C              size of block
  918.         IBLOCK(10)=32
  919. C              file type
  920.         IBLOCK(11)=0
  921. C              leaf name
  922.         IBLOCK(12)=0
  923. C              block length in bytes & dummy reference #
  924.         IBLOCK(1)=48
  925.         IBLOCK(4)=0
  926. C              action (1 = save)
  927.         IBLOCK(5)=1
  928. C              now send message
  929.         CALL WMPSMG(17,IBLOCK,IBLOCK(6),IBLOCK(7))
  930.         RETURN
  931.       ENDIF
  932. C           finished if not message received
  933.       IF(IREASN.NE.17.AND.IREASN.NE.18) RETURN
  934. C           data save message received by receiver
  935.       IF(IBLOCK(5).EQ.1) THEN
  936. C           check that it does not have a file name, 
  937. C           nor comes from this task
  938.         IF(IBLOCK(12).NE.0.OR.IBLOCK(2).EQ.ITHAND) RETURN
  939. C              clear buffer
  940.         DO 10 I=1,8
  941.           IFETCH(I)=-1
  942.    10   CONTINUE
  943. C              reply with RAMFetch
  944.         IBLOCK(6)=LOC(IFETCH)
  945.         IBLOCK(7)=32
  946.         IBLOCK(5)=6
  947.         IBLOCK(1)=28
  948.         CALL WMPSMG(17,IBLOCK,IBLOCK(2),I)
  949.         IREASN=-1
  950.         RETURN
  951.       ENDIF
  952. C           RAMfetch message received by originator
  953.       IF(IBLOCK(5).EQ.6) THEN
  954. C              transfer block of info
  955.         CALL WMPTB(ITHAND,LOC(ISEND),IBLOCK(2),IBLOCK(6),IBLOCK(7))
  956. C              send RAM transmit message
  957.         IBLOCK(1)=28
  958.         IBLOCK(5)=7
  959.         CALL WMPSMG(17,IBLOCK,IBLOCK(2),I)
  960.         IREASN=-1
  961.         RETURN
  962.       ENDIF
  963. C           RAMtransmit message received by receiver
  964.       IF(IBLOCK(5).EQ.7) THEN
  965.         II=0
  966.         DO 20 I=1,8
  967.           II=II+IFETCH(I)-ISEND(I)
  968.    20   CONTINUE
  969.         CALL WMPC2H('Testing '//LIST3(27),ITWT)
  970.         IBLOCK(1)=ITWHAN
  971.         CALL WMPGWS(IBLOCK)
  972.         IBLOCK(3)=IBLOCK(3)-256
  973.         IBLOCK(5)=IBLOCK(5)-256
  974.         CALL WMPOW(IBLOCK)
  975.         ITEST=-26
  976.         IREASN=-1
  977.       ENDIF
  978.       RETURN
  979.       END
  980.