home *** CD-ROM | disk | FTP | other *** search
/ RISC DISC 2 / RISC_DISC_2.iso / pd_share / program / fortran77_210 / library / f77 / drawf < prev    next >
Encoding:
Text File  |  1991-11-17  |  12.4 KB  |  378 lines
  1.       SUBROUTINE DRCHEK(IER)
  2. C           checks that this object size is less than page size
  3. C           returns IER = 0 if it is
  4.       INCLUDE 'CDE.DrawF'          
  5.       IER=0
  6.       IF(LP.EQ.0)THEN
  7. C              use the largest object regardless of size
  8.         IF(MINPX.LT.MINBOX)MINPX=MINBOX
  9.         IF(MAXPX.GT.MAXBOX)MAXPX=MAXBOX
  10.         IF(MINPY.LT.MINBOY)MINPY=MINBOY
  11.         IF(MAXPY.GT.MAXBOY)MAXPY=MAXBOY
  12.         RETURN
  13.       ELSE
  14.         IF(MINBOX.GT.MINPX.AND.MINBOY.GT.MINPY.AND.
  15.      1     MAXBOX.LT.MAXPX.AND.MAXBOY.LT.MAXPY)RETURN
  16.       ENDIF
  17.       IER=5
  18.       RETURN
  19.       END
  20.       SUBROUTINE DRFILE(PSIZE,FNAME,IER)
  21. C              control routine to make a DRAWfile in file FNAME
  22. C              returns IER =0 for success, othwise gives error number
  23. C              PSIZE is page size, =A4 check size of objects will go in,
  24. C                    error return if they won't, ="" set to size of largest
  25.       CHARACTER *(*) FNAME, PSIZE
  26.       PARAMETER (MAXPR=100,NSIZES=5,MAXCHR=255)
  27.       CHARACTER *3 PS(0:NSIZES-1)
  28. C                      user text
  29.       CHARACTER *1 CHARAY(MAXCHR)
  30.       DIMENSION ARRAY(2,MAXPR),LSIZES(2,0:NSIZES-1)
  31. C                dimensions of user co-ordinate pairs
  32.       INCLUDE 'CDE.DrawF'          
  33.       DATA PS   /' ',   'A4L', 'A4P',  'A5L',  'A5P'/        
  34.       DATA LSIZES/0,0,297,210,210,297,210,148,148,210/
  35. C                    scale is 1mm in internal Draw units (PRM p1489
  36. C  fudge below to get !Draw to get right page size, should be 25.4 really ??
  37.       SCALE=180.*256./25.5
  38. C                  check page size  flag
  39.       DO 6 I=0,NSIZES-1
  40.       IF(PS(I).NE.PSIZE)GOTO6
  41. C                   set page size flag in COMMON/DR/
  42.         LP=I  
  43.         GOTO8         
  44.     6 CONTINUE               
  45.       LP=0
  46.     8 MINPX=0.
  47.       MINPY=0.
  48. C               set page sizes according to the flag LP
  49.       MAXPX=LSIZES(1,LP)*SCALE
  50.       MAXPY=LSIZES(2,LP)*SCALE
  51. C                  open file FNAME for writing
  52.       CALL DROPEN(FNAME,IER)
  53.       IF(IER.NE.0)RETURN                   
  54. C                   set up DRAWfile header
  55.       CALL DRHEAD(IER)
  56.       IF(IER.NE.0)GOTO90
  57. C                   User routine to make the object, 
  58. C                   set up NPTS co-ordinate pairs in ARRAY
  59.       NPTS=0
  60. C                    set up default colour words on this call
  61.       L1=-1
  62.       L2=0
  63.       L3=0
  64.       L4=0
  65. C          solid line in black minimum width
  66.    10 CALL DRPOL(ARRAY,MAXPR,NPTS,L1,L2,L3,L4,IER)
  67.       IF(NPTS.LE.0)GOTO20
  68. C                   check for an error from the user routine
  69.       IF(IER.NE.0)GOTO90
  70. C                               store a DRAW path object in the file
  71.       CALL DRPATH(ARRAY,NPTS,L1,L2,L3,L4,IER)
  72.       IF(IER.NE.0)GOTO90                 
  73.       GOTO10
  74. C                  store a DRAW text object
  75.    20 NCHARS=0                                    
  76. C                  defaults for text
  77.       L1=0
  78. C                  text colour and hint
  79.       L2=?IFFFFFF00
  80. C                  text style (= font number)
  81.       L3=0
  82. C                  text size in points
  83.       L4=12
  84.    30 CALL DRCHAR(CHARAY,MAXCHR,NCHARS,L1,L2,L3,L4,XL,YL,IER)
  85.       IF(NCHARS.LE.0)GOTO40
  86. C              check for error from the user routine
  87.       IF(IER.NE.0)GOTO90
  88. C                        store a Text object in the file
  89.       CALL DRTEXT(CHARAY,NCHARS,L1,L2,L3,L4,XL,YL,IER)
  90.       IF(IER.NE.0)GOTO90
  91.       GOTO30
  92.    40 CONTINUE   
  93. C                   close the file                         
  94.    90 CALL DRCLOS                 
  95.       RETURN
  96.       END                       
  97.       SUBROUTINE DRHEAD(IER)
  98. C         sets up the header for the DRAWfile
  99. C
  100. C     12 bytes   filetype identifier padded with zeros
  101. C     12 bytes   application identifier padded with spaces zero terminated
  102. C      4 bytes for x,y at corners of bounding box lower left, top right
  103.       INCLUDE 'CDE.DrawF'
  104. C               1st 3 words are 'Draw', 201, 0
  105.       LBUF(1)=?I77617244
  106.       LBUF(2)=201
  107.       LBUF(3)=0
  108. C                a r D T
  109.       LBUF(4)=?I61724454
  110. C                     w
  111.       LBUF(5)=?I20202077   
  112.       LBUF(6)=?I20202020    
  113. C                    set page sizes from page flag LP
  114. C      MINPX=?I02F380
  115. C      MAXPX=?I06DA80
  116. C                   A4 size Landscape orientation from !molecule
  117. C      MINPY=?I012CC0
  118. C      MAXPY=?I050CC0
  119.       LBUF(7)=MINPX
  120.       LBUF(8)=MINPY
  121.       LBUF(9)=MAXPX
  122.       LBUF(10)=MAXPY                                                   
  123.       LB=10
  124.       CALL DRWRIT(LBUF,LB,0,IER)
  125.       RETURN
  126.       END
  127.       SUBROUTINE DRPATH(ARRAY,NPTS,L1,L2,L3,L4,IER)
  128. C creates a DRAW Path Object in LBUF from the NPTS co-ordinate pairs in ARRAY
  129. C returns dimensions of bounding box
  130. C  L1,L2,L3,L4 1ST 3 WORDS OF PATH HEADER
  131.       DIMENSION ARRAY(2,*),LPAT(10)
  132.       INCLUDE 'CDE.DrawF'         
  133. C                data for dash patterns
  134.       DATA LPAT/2*?I0900,2*?I1200,2*?I2400,?I2400,3*?I0900/
  135. C                  make the Path Object header
  136. C                  this is a path object type 2
  137.       LBUF(1)=2
  138. C           LBUF(2) is count, 3,4,5,6 size to be entered later
  139. C         word 1 =colour if filled, -1 otherwise
  140.       LBUF(7)=L1
  141. C           line colour black
  142.       LBUF(8)=L2               
  143. C           line width minimum, and joints as in Archive vol4#6 page 42
  144.       LBUF(9)=L3
  145. C      LBUF(10)=L4
  146.       LBUF(10)=?I20100042
  147.       LB=10
  148.       IF(L4.GT.0.AND.L4.LT.5)THEN
  149. C                     set up dotted lines set pattern bit
  150.         LBUF(10)=?I201000C2
  151. C                     offset to start of pattern
  152.         LBUF(11)=0
  153. C                number of elements in the following pattern
  154.         LBUF(12)=2
  155. C                pattern of dashes
  156.         LBUF(13)=LPAT(2*L4-1)
  157.         LBUF(14)=LPAT(2*L4)
  158.         LB=14
  159.         IF(L4.EQ.4)THEN
  160. C                    dashes and dots
  161.           LBUF(15)=LPAT(9)
  162.           LBUF(16)=LPAT(10)
  163.           LBUF(12)=4
  164.           LB=16
  165.         ENDIF
  166.       ENDIF
  167. C        Path Object header done, now add the picture from ARRAY
  168.       CALL DRPIC(LBUF(LB+1),LX,ARRAY,NPTS)
  169. C                     check that object size compatible with page size
  170.       CALL DRCHEK(IER)
  171.       IF(IER.NE.0)RETURN
  172.       LW=LB+LX
  173. C                      number of bytes stored in LBUF
  174.       LBUF(2)=LW*4
  175. C                        update path header with count and size
  176.       LBUF(3)=MINBOX
  177.       LBUF(4)=MINBOY
  178.       LBUF(5)=MAXBOX
  179.       LBUF(6)=MAXBOY                      
  180. C                       write out this path object
  181.       CALL DRWRIT(LBUF,LW,-1,IER)
  182.       RETURN
  183.       END       
  184.       SUBROUTINE DRPIC(MBUF,LB,ARRAY,NPTS)
  185. C    scales the NPTS pairs of co-ordinatesin ARRAY and moves them into LBUF
  186. C       returns LB number of words stored in MBUF
  187.       PARAMETER (MOVE=2,MDRAW=8,MTERM=0)
  188.       DIMENSION MBUF(*),ARRAY(2,*)
  189.       INCLUDE 'CDE.DrawF'
  190.       MINBOX=999999
  191.       MINBOY=999999
  192.       MAXBOX=-1
  193.       MAXBOY=-1      
  194. C                 initialise box min and max
  195.       LB=1
  196.       DO 20 I=1,NPTS           
  197.       IF(I.EQ.1)THEN
  198.         MBUF(LB)=MOVE
  199.       ELSE
  200.         MBUF(LB)=MDRAW
  201.       ENDIF
  202. C                        Scale x,y to mm units
  203.       IW=SCALE*ARRAY(1,I)
  204.       MBUF(LB+1)=IW 
  205.       IF(IW.LT.MINBOX)MINBOX=IW
  206.       IF(IW.GT.MAXBOX)MAXBOX=IW
  207.             IW=SCALE*ARRAY(2,I)
  208.       MBUF(LB+2)=IW
  209.       IF(IW.LT.MINBOY)MINBOY=IW
  210.       IF(IW.GT.MAXBOY)MAXBOY=IW 
  211.    20 LB=LB+3
  212. C                   all x,y pairs now stored, terminate with 00
  213.       MBUF(LB)=MTERM
  214.       RETURN
  215.       END                        
  216.       SUBROUTINE DRPOL(ARRAY,MAXPR,NPTS,L1,L2,L3,L4,IER)
  217. C Dummy User routine sets up co-ordinate pairs for lines into ARRAY
  218. C               assume units mm,  MAXPR max no of pairs, NPTS returned   
  219.       DIMENSION ARRAY(2,MAXPR)                             
  220.       IER=0
  221.       RETURN
  222.       END
  223.       SUBROUTINE DRCHAR(CHARAY,MAXCHR,NCHARS,L1,L2,L3,L4,XL,YL,IER)
  224.       CHARACTER *(*) CHARAY
  225. C Dummy user routine to set up text
  226.       IER=0
  227.       RETURN
  228.       END
  229.       SUBROUTINE DRTEXT(CHARAY,NCHARS,L1,L2,L3,L4,XL,YL,IER)
  230. C creates a DRAW Text Object from the NCHARS characters in CHARAY
  231. C L1,L2 are colours of text, L3 font number, L4 size (same for x and y)
  232. C XL,YL lower left corner of text in the picture, IER =error return
  233.       CHARACTER *1 CHARAY(*)
  234.       INCLUDE 'CDE.DrawF'                                          
  235.       IER=0
  236. C                  make the Text Object header path object type 1
  237.       LBUF(1)=1
  238. C           LBUF(2) is count, 3,4,5,6 box size to be entered later
  239. C         word 1= colour word, 2= colour of hint, 3=style(font no)
  240.       LBUF(7)=L1
  241.       LBUF(8)=L2               
  242.       LBUF(9)=L3
  243. C         10,11 are x,y sizes of font, units are 1/640 of a point 
  244.       LBUF(10)=L4*640
  245.       LBUF(11)=LBUF(10)
  246. C         lower left corner of start of text
  247.       MINBOX=XL*SCALE
  248.       MINBOY=YL*SCALE
  249. C                set bounding box lower left
  250. C                 upper y value = 1 character
  251.       MAXBOY=MINBOY+LBUF(11)
  252. C                  assume monospacing in x check width will go in
  253.       MAXBOX=MINBOX+LBUF(10)*NCHARS
  254. C                  allow for other objects already stored
  255.       CALL DRCHEK(IER)
  256.       IF(IER.NE.0)THEN
  257.         IER=6
  258.         RETURN
  259.       ENDIF
  260. C                 set box sizes into header
  261.       LBUF(12)=MINBOX
  262.       LBUF(13)=MINBOY
  263.       LB=13      
  264. C        Text Object header done, now add the characters from ARRAY
  265. C        must have text in a whole number of words, null filled
  266.       NADD=1+(NCHARS/4)
  267.       ICH=1
  268.       IZERO=0
  269.       DO 20 I=1,NADD
  270.       IW=0
  271.       DO 10 J=0,24,8 
  272.       IF(ICH.LE.NCHARS)THEN
  273.         IW=IOR(IW,ISHFT(ICHAR(CHARAY(ICH)),J))
  274.       ELSE
  275.         IW=IOR(IW,ISHFT(IZERO,J))
  276.       ENDIF
  277.       ICH=ICH+1
  278.    10 CONTINUE      
  279.       LBUF(LB+I)=IW
  280.    20 CONTINUE
  281. C                      number of bytes stored in LBUF
  282.       LBUF(2)=(LB+NADD)*4
  283. C                        update path header with count and size
  284.       LBUF(3)=MINBOX
  285.       LBUF(4)=MINBOY
  286.       LBUF(5)=MAXBOX
  287.       LBUF(6)=MAXBOY 
  288.       LW=LB+NADD                     
  289. C                       write out this path object
  290.       CALL DRWRIT(LBUF,LW,-1,IER)
  291.       RETURN
  292.       END
  293.       SUBROUTINE DROBJ(ARRAY,NWDS,IER)
  294. C                   Write out NWDS words of ARRAY set up by the user
  295.       IER=0
  296.       RETURN
  297.       END
  298.       SUBROUTINE SAVMEM(LBUF,LB,FILNAM,IER)
  299.       DIMENSION LBUF(*),IREGS(0:7)
  300.       CHARACTER *(*) FILNAM
  301.       CHARACTER *20 FTERM         
  302.       DATA IREGS/10,7*0/
  303. C           saves array LBUF, length LB, to file, FILNAM
  304.       IER=0
  305.       FTERM=FILNAM//CHAR(0)
  306.       IREGS(1)=LOCC(FTERM)
  307.       IREGS(2)=?I0AFF
  308. C                      filetype Draw
  309.       IREGS(4)=LOC(LBUF)    
  310. C                              LB=words, but need Byte address
  311.       IREGS(5)=IREGS(4)+LB*4    
  312. C                     writes out contents of LBUF to file (SWI 8 =OSFILE)
  313.       CALL SWIF77(8,IREGS,IFLAG)
  314. C              ought to have an IER error return here
  315.       RETURN
  316.       END
  317.       SUBROUTINE DRWRIT(LBUF,NWD,IWD,IER)
  318. C           write out NWD words form array LBUF to the open file
  319. C           IWD < 0 appends to end after latest block written
  320. C           IWD >=0 writes at position IWD in the file
  321.       PARAMETER(IGBPB=12,IFIND=13,IFILE=8)
  322.       CHARACTER FNAME*(*),NAME*50
  323.       DIMENSION LBUF(*),IREGS(0:7)
  324.       DATA IHANDL/0/                                  
  325.       IER=0
  326. C                     set the error flag to zero
  327. C           file must be open to write
  328.       IF(IHANDL.EQ.0) THEN
  329.          IER=3
  330.          RETURN 
  331.       ENDIF
  332.       IF(IWD.GE.0) THEN
  333. C           put data in file at word IWD
  334.         IREGS(0)=1
  335.         IREGS(4)=4*IWD
  336.       ELSE
  337. C           append data to file, but remember that this is not necessarily
  338. C                                at the end of the file!!!
  339.         IREGS(0)=2
  340.       ENDIF
  341.       IREGS(1)=IHANDL
  342.       IREGS(2)=LOC(LBUF)
  343.       IREGS(3)=4*NWD
  344.       CALL SWIF77(IGBPB,IREGS,IFLAG)
  345. C            should test for errors someday and set IER depending on IFLAG
  346.       RETURN
  347. C            open file here -----------------------------------------
  348.       ENTRY DROPEN(FNAME,IER)
  349.       IER=0
  350.       IF(IHANDL.NE.0) THEN
  351. C            can't open already open file!
  352.         IER=2
  353.         RETURN
  354.       ENDIF
  355. C             null terminate file name
  356.       NAME=FNAME//CHAR(0)
  357.       IREGS(0)=128
  358.       IREGS(1)=LOCC(NAME)
  359.       CALL SWIF77(IFIND,IREGS,IFLAG)
  360. C               must check value of IFLAG and return IER <> 0
  361.       IHANDL=IREGS(0)
  362.       RETURN
  363. C           close file here -------------------------------------------
  364.       ENTRY DRCLOS
  365. C           no file to close?
  366.       IF(IHANDL.EQ.0) RETURN
  367.       IREGS(0)=0
  368.       IREGS(1)=IHANDL
  369.       CALL SWIF77(IFIND,IREGS,IFLAG)
  370.       IHANDL=0
  371. C           set file type of 'NAME' to &AFF (DrawFile)
  372.       IREGS(0)=18
  373.       IREGS(1)=LOCC(NAME)
  374.       IREGS(2)=?I0AFF
  375.       CALL SWIF77(IFILE,IREGS,IFLAG)
  376.       RETURN
  377.       END
  378.