home *** CD-ROM | disk | FTP | other *** search
/ Archive Magazine 1996 / ARCHIVE_96.iso / discs / shareware / share_44 / sphererot / !SphereRot / f77 / SphereRot
Text File  |  1992-09-14  |  21KB  |  707 lines
  1.       PROGRAM SphereRot
  2. C  Create 2 sphere sprites and rotate them with selection of shapes      
  3. C      Copyright K.M. Crennell 1 Dec 1991
  4. C      Last update prompts for new mode 3/6/92
  5. C      Prev. update to check successful write to sprite file 18/5/92
  6. C
  7. C    PD_f77  libraries needed   Graphics SpriteOps Utils
  8. C
  9. C                                       COMMON BLOCK
  10.       PARAMETER(MXPNTS=99,ISPSIZ=40000)
  11.       COMMON IND(MXPNTS),X(MXPNTS),Y(MXPNTS),Z(MXPNTS),ISP(ISPSIZ),
  12.      2 KOL(MXPNTS),XP,YP,ZP,Z0,DS,ZMIN,ZMAX,ISH,MAXR,NSPRIT,MAXS,
  13.      3 IYBYX,MODES,MX,MY,MB,MXO,MYO,MBO,NPTS
  14.       DIMENSION IREGS(0:7)
  15.       LOGICAL SWIF77
  16.       COMMON/SPNAM/SPR(0:1,0:19)
  17.       CHARACTER*3 SPR
  18. C
  19. C           get screensize
  20.       IREGS(0)=2
  21.       IF(SWIF77(?I5C,IREGS,IFLAG))THEN
  22. C            can't get screen size
  23.          PRINT *,' Can not get screen size'
  24.          STOP
  25.       ENDIF       
  26. C           set screensize to 320K
  27.       IREGS(0)=2
  28.       IREGS(1)=320*1024-IREGS(1)
  29.       IF(SWIF77(?I2A,IREGS,IFLAG))THEN
  30. C            can't set screen size
  31.          PRINT *,' Can not set screen size to 320K'
  32.          STOP
  33.       ENDIF       
  34.       CALL INIT                   
  35.       N=1
  36.       CALL SWAP(N)
  37.       CALL CLS
  38.       CALL SWAP(N)
  39.       CALL ORIGIN (640,512 )
  40.       CALL CURSOR(.FALSE.)
  41. C                set default initial object to be shape 6
  42.       ISH=6
  43.       CALL NEW
  44.       CALL OSBYTE(4,1,0)
  45.       CALL OSBYTE(11,64,0)
  46. C                       Increment in x,y,z of image
  47.       SS=20.
  48. C                     ------------start of main loop----------
  49.    10 CONTINUE
  50.       CALL MOUSE (MY,MX,MB)
  51. C                                     left mouse button
  52.       IF(MB.EQ.1) ZP=ZP+SS
  53. C                                     right mouse button
  54.       IF(MB.EQ.4) ZP=ZP-SS
  55.       IC=INKEY(0)
  56.       IF(IC.GE.48 .AND.IC.LE.9+48)THEN
  57. C                               ask for a new object (INDEX  by IC)
  58.         ISH=IC-48
  59.         CALL NEW
  60.       ENDIF
  61.       IF(IC.EQ.136)XP=XP-SS
  62. C                                     left arrow
  63.       IF(IC.EQ.137)XP=XP+SS
  64. C                                     right arrow
  65.       IF(IC.EQ.138)YP=YP-SS
  66. C                                     down arrow
  67.       IF(IC.EQ.139)YP=YP+SS
  68. C                                     up arrow
  69.       IF(IC.EQ.81.OR.IC.EQ.113.OR.IC.EQ.27)CALL QUIT
  70.       IF(MX.NE.MXO.OR.MY.NE.MYO) THEN
  71.         CALL ROTAT
  72.         CALL QSORTR(Z,IND,NPTS)
  73.       ENDIF
  74.       CALL CLS
  75.       CALL PLOTP
  76.       CALL TAB(0,0)
  77.       CALL WOT(0,0,'Possible keys are 1 2 3 4 5 6 7 8 9 0 Q')
  78.       CALL WOT(0,2,'This is Shape '//CHAR(ISH+48))
  79.       CALL swap(N)
  80. C                        ------------end of main loop-------
  81.       GOTO10
  82.       END
  83.       SUBROUTINE GREYS
  84.       DO 10 K=1,7
  85.       IA=K*16
  86. C                    red balls
  87.       CALL VDU19(K+7,16,IA+128,IA    ,IA)
  88. C                    green balls
  89.       CALL VDU19(K  ,16,IA    ,IA+128,IA)
  90.    10 CONTINUE                
  91. C                  blue background colour
  92.       CALL VDU19( 0,16,0,0,112)
  93.       CALL VDU19(15,16,240,240,240)
  94.       RETURN
  95.       END
  96.       SUBROUTINE INIT
  97. C                                       COMMON BLOCK
  98.       PARAMETER(MXPNTS=99,ISPSIZ=40000,MAXSP=40)
  99.       COMMON IND(MXPNTS),X(MXPNTS),Y(MXPNTS),Z(MXPNTS),ISP(ISPSIZ),
  100.      2 KOL(MXPNTS),XP,YP,ZP,Z0,DS,ZMIN,ZMAX,ISH,MAXR,NSPRIT,MAXS,
  101.      3 IYBYX,MODES,MX,MY,MB,MXO,MYO,MBO,NPTS         
  102.       COMMON/SPNAM/SPR(0:1,0:MAXSP-1)
  103.       CHARACTER*3 SPR
  104.       CHARACTER*19 SPFILE,ERRTXT*30
  105.       LOGICAL SPOP12
  106. C           sprite size ISP now in WORDS not BYTES (was &FBB)
  107.       CALL INTRO
  108. C                      screen MODE
  109.     5 CALL WOG(200,80,' Screen Mode (27 or 12 or 9) ?')
  110.       CALL VDU(5)
  111.       READ(*,*,ERR=5)MODES
  112.       IF(MODES.EQ.27) THEN
  113.         SPFILE='<SphR$Dir>.SphRot27'
  114.       ELSE IF(MODES.EQ.12) THEN
  115.         SPFILE='<SphR$Dir>.SphRot12'
  116.       ELSE IF(MODES.EQ.9) THEN
  117.         SPFILE='<SphR$Dir>.SphRot9'
  118.       ELSE
  119.         CALL VDU(7)
  120.         CALL CLS
  121.         GO TO 5
  122.       ENDIF
  123.       CALL MODE(MODES)
  124. C           get rasters to pixels ratio in x & y
  125.       IXPIX=ISHFT(1,MODEVAR(-1,4))
  126.       IYPIX=ISHFT(1,MODEVAR(-1,5))              
  127. C           ratio of y to x rasters (1 or 2)
  128.       IYBYX=IYPIX/IXPIX
  129.       Z0=1000
  130.       ZMIN=-500
  131.       ZMAX=2000
  132.       MAXR=72/IXPIX
  133.       RZMAX=Z0/(Z0+ZMAX)
  134.       RZMIN=Z0/(Z0+ZMIN)
  135.       MINR=MAXR*RZMAX/RZMIN
  136.       NSPRIT=MAXR-MINR+1
  137.       IF(NSPRIT.GT.MAXSP) THEN
  138.         PRINT*,' Too many sprites, maxr,minr=',MAXR,MINR
  139.         STOP
  140.       ENDIF
  141.       DS=NSPRIT/(RZMIN-RZMAX)
  142.       MAXS=DS*RZMIN
  143.       IS=16
  144.       DO 20 IRX=MINR,MAXR
  145.       IDX=IRX+IRX+1
  146.       IRY=IRX/IYBYX
  147.       IDY=IRY+IRY+1
  148.       IS=IS+88
  149.       IS=IS+16*IDY*((IDX+7)/8)
  150.       I=MAXR-IRX
  151.       DO 10 IB=0,1
  152.       IF(I.GT.9) THEN
  153.         SPR(IB,I)=CHAR(96+IB)//CHAR(48+I/10)//CHAR(48+MOD(I,10))
  154.       ELSE
  155.         SPR(IB,I)=CHAR(96+IB)//CHAR(48+I)//CHAR(0)
  156.       ENDIF
  157.    10 CONTINUE
  158.    20 CONTINUE
  159.       PRINT *,' Calculated sprite size: ',IS
  160.       IF(IS.GT.ISPSIZ*4) STOP 'Sprite area too small'
  161.       ISP(1)=ISPSIZ*4
  162.       ISP(2)=0
  163.       ISP(3)=16
  164.       ISP(4)=16
  165. C       make MOUSE STEP 1         
  166.       CALL OSWORD(21,?I010102)
  167.       CALL GREYS
  168. C                if file exists may as well use it, find out 
  169.       CALL GETDIR('<SphR$Dir>',SPFILE(12:17),N)
  170. C                 read the sprite file
  171.       CALL SPOP10(ISP,SPFILE,*900)
  172.       RETURN
  173.   900 PRINT 104,SPFILE
  174.   104 FORMAT(' cannot find sprite file ',A/$,
  175.      +' Change mode, Make sprites or Quit')
  176.       I=IG('CMQ')
  177.       IF(I.EQ.1) GO TO 5
  178.       IF(I.EQ.3)CALL QUIT
  179.   910 CALL MAKESP
  180.       PRINT 103
  181.   103 FORMAT($' Save sprites to file')
  182.       IF(IG('NY').EQ.2) THEN
  183.         IF(SPOP12(ISP,SPFILE)) THEN
  184.           CALL SPOPER(I,ERRTXT,N)
  185.           PRINT 105,ERRTXT(1:N)
  186.   105     FORMAT(1X,A/' C to continue, Q to quit',$)
  187.           IF(IG('CQ').EQ.2) CALL QUIT
  188.         ENDIF
  189.       ENDIF
  190.       RETURN
  191.       END
  192.       SUBROUTINE INTRO
  193. C          writes up the introductory screen.
  194.       CALL VDU(26)
  195.       CALL CLS
  196.       LX=200
  197.       LY=800
  198.       CALL WOGBIG(LX+200,LY,'SphereRot',3)
  199.       CALL WOG(LX,LY-100,
  200.      1             'A program demonstrating the use of SpriteOps from')
  201.       CALL WOG(LX,LY-160,
  202.      1     'the "Fortran Friends" PD_F77 library, to manipulate')
  203.       CALL WOG(LX,LY-220,
  204.      1             'objects made from groups of spheres.')
  205.       CALL WOG(LX+300,LY-360, 'K.M.Crennell')
  206.       CALL WOG(LX+348,LY-440,'1991')
  207. C    5 PRINT 101
  208. C  101 FORMAT($,)
  209. C      CALL TAB(10,48)
  210.       RETURN
  211.       END
  212.       SUBROUTINE MakeSp
  213. C                           makes the initial sprite
  214.       PARAMETER (RTODEG=57.29578)
  215. C                                       COMMON BLOCK
  216.       PARAMETER(MXPNTS=99,ISPSIZ=40000)
  217.       COMMON IND(MXPNTS),X(MXPNTS),Y(MXPNTS),Z(MXPNTS),ISP(ISPSIZ),
  218.      2 KOL(MXPNTS),XP,YP,ZP,Z0,DS,ZMIN,ZMAX,ISH,MAXR,NSPRIT,MAXS,
  219.      3 IYBYX,MODES,MX,MY,MB,MXO,MYO,MBO,NPTS         
  220.       COMMON/SPNAM/SPR(0:1,0:19)
  221.       CHARACTER*3 SPR
  222. C         viewing angles in degrees
  223.       DATA AL1,AL2/30.,30./
  224.       CALL SPOP09(ISP)
  225.       DO 40 IS=0,NSPRIT-1
  226.       IRX=MAXR-IS
  227.       IDX=IRX+IRX+1
  228.       IRY=IRX/IYBYX
  229.       IDY=IRY+IRY+1
  230.       IR2=IRX*IRX+IRX
  231.       IYBYX2=IYBYX*IYBYX
  232.       DO 10 IB=0,1
  233.       CALL SPOP15(ISP,SPR(IB,IS),0,IDX,IDY,MODES)
  234.       CALL SPOP29(ISP,SPR(IB,IS))
  235.    10 CONTINUE
  236.       PRINT 101,IS,IRX,ISP(4)
  237.   101 FORMAT(' Making Sprites',I3,', radius',I3,', space used',I6)
  238. C                         -------------------- start drawing sprite
  239.       DO 30 IY=-IRY,IRY
  240.       KY=IRY+IY
  241.       DO 20 IX=-IRX,IRX
  242.       KX=IRX+IX
  243.       IF(IX*IX+IY*IY*IYBYX2.LE.IR2) THEN
  244.         D1=ABS(RTODEG*ASIN(FLOAT(IX)/IRX)-AL1)
  245.         D2=ABS(RTODEG*ASIN(FLOAT(IY)/IRY)-AL2)
  246.         IC=6.99-SQRT(D1*D1+D2*D2)/14.-RND01()
  247.         IF(IC.LT.0) IC=0
  248.         CALL SPOP42(ISP,SPR(0,IS),KX,KY,IC+1)
  249.         CALL SPOP42(ISP,SPR(1,IS),KX,KY,IC+8)
  250.       ELSE
  251.         CALL SPOP44(ISP,SPR(0,IS),KX,KY,0)
  252.         CALL SPOP44(ISP,SPR(1,IS),KX,KY,0)
  253.       ENDIF
  254.    20 CONTINUE
  255.    30 CONTINUE
  256.    40 CONTINUE
  257. C                     ------------------end of sprite creation
  258.       RETURN
  259.       END
  260.       SUBROUTINE PLOTP                              
  261. C                                       COMMON BLOCK
  262.       PARAMETER(MXPNTS=99,ISPSIZ=40000)
  263.       COMMON IND(MXPNTS),X(MXPNTS),Y(MXPNTS),Z(MXPNTS),ISP(ISPSIZ),
  264.      2 KOL(MXPNTS),XP,YP,ZP,Z0,DS,ZMIN,ZMAX,ISH,MAXR,NSPRIT,MAXS,
  265.      3 IYBYX,MODES,MX,MY,MB,MXO,MYO,MBO,NPTS         
  266.       COMMON/SPNAM/SPR(0:1,0:19)
  267.       CHARACTER*3 SPR
  268. C
  269.       I=IND(NPTS)
  270.       IF(Z(I)+ZP.GT.ZMAX) ZP=ZMAX-Z(I)
  271.       I=IND(1)
  272.       IF(Z(I)+ZP.LT.ZMIN) ZP=ZMIN-Z(I)
  273.       DO 10 J=NPTS,1,-1
  274.       I=IND(J)
  275.       FACT=Z0/(Z0+ZP+Z(I))
  276.       IS=MAXS-FACT*DS
  277.       IF(IS.LT.0) IS=0
  278.       CALL SPOP34(ISP,SPR(KOL(I),IS),INT(fact*(X(I)+XP)),
  279.      1            INT(fact*Y(I)+YP),8)
  280.    10 CONTINUE
  281.       RETURN
  282.       END
  283.       SUBROUTINE ROTAT        
  284.       PARAMETER(DEGTOR=0.017453293)
  285. C                                       COMMON BLOCK
  286.       PARAMETER(MXPNTS=99,ISPSIZ=40000)
  287.       COMMON IND(MXPNTS),X(MXPNTS),Y(MXPNTS),Z(MXPNTS),ISP(ISPSIZ),
  288.      2 KOL(MXPNTS),XP,YP,ZP,Z0,DS,ZMIN,ZMAX,ISH,MAXR,NSPRIT,MAXS,
  289.      3 IYBYX,MODES,MX,MY,MB,MXO,MYO,MBO,NPTS         
  290.       COMMON/SPNAM/SPR(0:1,0:19)
  291.       CHARACTER*3 SPR
  292. C           
  293.       CY=COS(DEGTOR*(MY-MYO))
  294.       SY=SIN(DEGTOR*(MY-MYO))
  295.       C=COS(DEGTOR*(MX-MXO))
  296.       S=SIN(DEGTOR*(MX-MXO))
  297.       DO 20 I=1, NPTS
  298.       Z2=Z(I)*cy+X(I)*SY
  299.       X(I)=X(I)*CY-Z(I)*SY
  300.       Y2=Y(I)*C-Z2*S
  301.       Z(I)=Z2*C+Y(I)*S
  302.       Y(I)=Y2
  303.    20 CONTINUE
  304.       MYO=MY
  305.       MXO=MX
  306.       RETURN
  307.       END
  308.       SUBROUTINE swap(N)
  309.       CALL OSBYTE(19,0,0)
  310. C                     WAIT for sync
  311. C              swap the shadow memory
  312.       CALL OSBYTE(113,N,0)
  313.       N= 3-N
  314.       CALL OSBYTE(112,N,0)
  315.       RETURN
  316.       END
  317.       SUBROUTINE NEW
  318. C                                       COMMON BLOCK
  319.       PARAMETER(MXPNTS=99,ISPSIZ=40000)
  320.       COMMON IND(MXPNTS),X(MXPNTS),Y(MXPNTS),Z(MXPNTS),ISP(ISPSIZ),
  321.      2 KOL(MXPNTS),XP,YP,ZP,Z0,DS,ZMIN,ZMAX,ISH,MAXR,NSPRIT,MAXS,
  322.      3 IYBYX,MODES,MX,MY,MB,MXO,MYO,MBO,NPTS         
  323.       COMMON/SPNAM/SPR(0:1,0:19)
  324.       CHARACTER*3 SPR
  325. C
  326.       NPTS=0
  327.       IRAD=30       
  328.       IF(ISH.EQ.0)CALL RDDTMM
  329.       IF(ISH.EQ.1)CALL PLANE
  330.       IF(ISH.EQ.2)CALL DISC(.FALSE.)
  331.       IF(ISH.EQ.3)CALL DISC(.TRUE.)
  332.       IF(ISH.EQ.4)CALL shapes(0,270,90,90,270,180)
  333.       IF(ISH.EQ.5)CALL shapes(30,330,60,30,330,60)
  334.       IF(ISH.EQ.6)CALL Cubic
  335.       IF(ISH.EQ.7)CALL BCC
  336.       IF(ISH.EQ.8)CALL RDdata 
  337.       IF(ISH.EQ.9)CALL RDshak
  338.       XP=0.
  339.       YP=0.
  340.       ZP=0.
  341.       DO 10 I=1,NPTS
  342.    10 IND(I)=I
  343.       CALL QSORTR(Z,IND,NPTS)
  344.       CALL MOUSE(MYO,MXO,MBO)
  345.       RETURN
  346.       END
  347.       SUBROUTINE plane
  348. C                                       COMMON BLOCK
  349.       PARAMETER(MXPNTS=99,ISPSIZ=40000)
  350.       COMMON IND(MXPNTS),X(MXPNTS),Y(MXPNTS),Z(MXPNTS),ISP(ISPSIZ),
  351.      2 KOL(MXPNTS),XP,YP,ZP,Z0,DS,ZMIN,ZMAX,ISH,MAXR,NSPRIT,MAXS,
  352.      3 IYBYX,MODES,MX,MY,MB,MXO,MYO,MBO,NPTS         
  353.       COMMON/SPNAM/SPR(0:1,0:19)
  354.       CHARACTER*3 SPR
  355. C
  356.       DO 20 JX=-200,200,200
  357.       DO 20 JY=-200,200,200
  358.       NPTS=NPTS+1
  359.       X(NPTS)=JX
  360.       Y(NPTS)=JY
  361.       Z(NPTS)=0    
  362.       KOL(NPTS)=0
  363.    20 CONTINUE
  364.       RETURN
  365.       END
  366.       SUBROUTINE disc(NF)
  367. C                                       COMMON BLOCK
  368.       PARAMETER(MXPNTS=99,ISPSIZ=40000)
  369.       COMMON IND(MXPNTS),X(MXPNTS),Y(MXPNTS),Z(MXPNTS),ISP(ISPSIZ),
  370.      2 KOL(MXPNTS),XP,YP,ZP,Z0,DS,ZMIN,ZMAX,ISH,MAXR,NSPRIT,MAXS,
  371.      3 IYBYX,MODES,MX,MY,MB,MXO,MYO,MBO,NPTS         
  372.       COMMON/SPNAM/SPR(0:1,0:19)
  373.       CHARACTER*3 SPR
  374. C
  375.       LOGICAL NF
  376.       PARAMETER(DEGTOR=0.017453293,IRAD=300)
  377.       DO 10  IA=0,330,30
  378.       NPTS=NPTS+1
  379.       X(NPTS)=IRAD*SIN(DEGTOR*IA)
  380.       Y(NPTS)=IRAD*COS(DEGTOR*IA)
  381.       Z(NPTS)=0
  382.       KOL(NPTS)=0
  383.       IF (IA.NE.0. AND.IA.NE.180. AND. NF) THEN
  384.         NPTS=NPTS+1
  385.         Z(NPTS)=X(NPTS-1)
  386.         Y(NPTS)=Y(NPTS-1)
  387.         X(NPTS)=0
  388.         KOL(NPTS)=1
  389.       ENDIF
  390.    10 CONTINUE
  391.       RETURN
  392.       END
  393.       SUBROUTINE shapes(Ib1,If1,Is1,Ib2,If2,Is2)
  394.       PARAMETER(DEGTOR=0.017453293,IRAD=200)
  395. C                                       COMMON BLOCK
  396.       PARAMETER(MXPNTS=99,ISPSIZ=40000)
  397.       COMMON IND(MXPNTS),X(MXPNTS),Y(MXPNTS),Z(MXPNTS),ISP(ISPSIZ),
  398.      2 KOL(MXPNTS),XP,YP,ZP,Z0,DS,ZMIN,ZMAX,ISH,MAXR,NSPRIT,MAXS,
  399.      3 IYBYX,MODES,MX,MY,MB,MXO,MYO,MBO,NPTS         
  400.       COMMON/SPNAM/SPR(0:1,0:19)
  401.       CHARACTER*3 SPR
  402. C
  403.       DO 10 IA=Ib1,If1,Is1
  404.       NPTS=NPTS+1
  405.       X(NPTS)=IRAD*SIN(DEGTOR*IA)
  406.       Y(NPTS)=IRAD*COS(DEGTOR*IA)
  407.       KOL(NPTS)=1
  408.    10 Z(NPTS)=0
  409.       DO 20 IA=Ib2,If2,Is2
  410.       NPTS=NPTS+1
  411.       Z(NPTS)=IRAD*SIN(DEGTOR*IA)
  412.       Y(NPTS)=IRAD*COS(DEGTOR*IA)
  413.       KOL(NPTS)=0
  414.    20 X(NPTS)=0
  415.       RETURN
  416.       END
  417.       SUBROUTINE Cubic
  418. C                                       COMMON BLOCK
  419.       PARAMETER(MXPNTS=99,ISPSIZ=40000)
  420.       COMMON IND(MXPNTS),X(MXPNTS),Y(MXPNTS),Z(MXPNTS),ISP(ISPSIZ),
  421.      2 KOL(MXPNTS),XP,YP,ZP,Z0,DS,ZMIN,ZMAX,ISH,MAXR,NSPRIT,MAXS,
  422.      3 IYBYX,MODES,MX,MY,MB,MXO,MYO,MBO,NPTS         
  423.       COMMON/SPNAM/SPR(0:1,0:19)
  424.       CHARACTER*3 SPR
  425. C
  426.       IC=0
  427.       DO 10 JX=-240,240,160
  428.       IC=1-IC
  429.       DO 10 JY=-240,240,160
  430.       IC=1-IC
  431.       DO 10 JZ=-240,240,160
  432.       IC=1-IC
  433.       NPTS=NPTS+1
  434.       KOL(NPTS)=IC
  435.       X(NPTS)=JX
  436.       Y(NPTS)=JY
  437.    10 Z(NPTS)=JZ
  438.       RETURN
  439.       END
  440.       SUBROUTINE BCC
  441. C           body-centred cubic
  442. C                                       COMMON BLOCK
  443.       PARAMETER(MXPNTS=99,ISPSIZ=40000)
  444.       COMMON IND(MXPNTS),X(MXPNTS),Y(MXPNTS),Z(MXPNTS),ISP(ISPSIZ),
  445.      2 KOL(MXPNTS),XP,YP,ZP,Z0,DS,ZMIN,ZMAX,ISH,MAXR,NSPRIT,MAXS,
  446.      3 IYBYX,MODES,MX,MY,MB,MXO,MYO,MBO,NPTS         
  447.       COMMON/SPNAM/SPR(0:1,0:19)
  448.       CHARACTER*3 SPR
  449. C
  450.       DO 10 JX=-160,160,160
  451.       DO 10 JY=-160,160,160
  452.       DO 10 JZ=-160,160,160
  453.       NPTS=NPTS+1
  454.       KOL(NPTS)=0
  455.       X(NPTS)=JX
  456.       Y(NPTS)=JY
  457.    10 Z(NPTS)=JZ
  458.       DO 20 JX=-80,80,160
  459.       DO 20 JY=-80,80,160
  460.       DO 20 JZ=-80,80,160
  461.       NPTS=NPTS+1
  462.       KOL(NPTS)=1
  463.       X(NPTS)=JX
  464.       Y(NPTS)=JY
  465.    20 Z(NPTS)=JZ
  466.       RETURN
  467.       END
  468.       SUBROUTINE RDdata
  469. C                                       COMMON BLOCK
  470.       PARAMETER(MXPNTS=99,ISPSIZ=40000)
  471.       COMMON IND(MXPNTS),X(MXPNTS),Y(MXPNTS),Z(MXPNTS),ISP(ISPSIZ),
  472.      2 KOL(MXPNTS),XP,YP,ZP,Z0,DS,ZMIN,ZMAX,ISH,MAXR,NSPRIT,MAXS,
  473.      3 IYBYX,MODES,MX,MY,MB,MXO,MYO,MBO,NPTS         
  474.       COMMON/SPNAM/SPR(0:1,0:19)
  475.       CHARACTER*3 SPR
  476. C
  477. C                             face centred cube
  478.       DIMENSION IB(4,15)
  479.       DATA IB/ 150,-150,-150,0,  150, 150,-150,0,
  480.      1         150, 150, 150,0,  150,-150, 150,0,
  481.      1        -150,-150,-150,0, -150, 150,-150,0,
  482.      2        -150, 150, 150,0, -150,-150, 150,0,
  483.      2          0,  0,-150,1,   0,  0, 150,1,
  484.      3          0, 150,  0,1,   0,-150,  0,1,
  485.      3         150,  0,  0,1, -150,  0,  0,1,
  486.      4        999,999,999,0/
  487. C
  488.    10 NPTS=NPTS+1
  489.       X(NPTS)=IB(1,NPTS)
  490.       Y(NPTS)=IB(2,NPTS)
  491.       Z(NPTS)=IB(3,NPTS)
  492.       KOL(NPTS)=IB(4,NPTS)
  493.       IF(X(NPTS).NE.999.AND.NPTS.NE.(MXPNTS-1))GOTO10
  494.       NPTS=NPTS-1
  495.       RETURN
  496.       END
  497.       SUBROUTINE RDDTMM
  498. C                                       COMMON BLOCK
  499.       PARAMETER(MXPNTS=99,ISPSIZ=40000)
  500.       COMMON IND(MXPNTS),X(MXPNTS),Y(MXPNTS),Z(MXPNTS),ISP(ISPSIZ),
  501.      2 KOL(MXPNTS),XP,YP,ZP,Z0,DS,ZMIN,ZMAX,ISH,MAXR,NSPRIT,MAXS,
  502.      3 IYBYX,MODES,MX,MY,MB,MXO,MYO,MBO,NPTS         
  503.       PARAMETER(SCALE=50.0)
  504.       CHARACTER CARD*72,EL*2,NAME*30,EL1*2,FRED*30
  505.       CALL MODE(MODES)
  506.       CALL GREYS
  507.       CALL ORIGIN (640,512 )
  508.       XC=0.
  509.       YC=0.
  510.       ZC=0.
  511. C                   show user possible files
  512.       CALL GETDIR('<SphR$Dir>','DTM',N)
  513.       IF(N.LT.1)THEN
  514.         WRITE(*,*)' Sorry, no DTM files in directory'
  515.         RETURN
  516.       ENDIF
  517.    10 PRINT 101
  518.   101 FORMAT($,'DTMM file name? ')
  519.       READ (*,102,ERR=10) NAME
  520.   102 FORMAT(A)
  521.       OPEN(9,FILE='<SphR$Dir>.'//NAME,STATUS='OLD',FORM='FORMATTED'
  522.      1 ,ERR=99)
  523. C               read unit cell sizes
  524.       READ(9,103,ERR=99,END=99)A,B,C
  525.   103 FORMAT(40X,3F8.3)
  526. C                 skip angles lines for now
  527.       READ(9,102,ERR=98)CARD
  528. C             A,B,C are unit cell size, now scale to screen
  529.       A=A*SCALE
  530.       B=B*SCALE
  531.       C=C*SCALE
  532.       READ(9,104,ERR=98)NPTS
  533.   104 FORMAT(I4)
  534.       IF(NPTS.GT.MXPNTS)THEN
  535.          PRINT *,' max points exceeded'
  536.          NPTS=MXPNTS
  537.          CALL VDU(7)
  538.       ENDIF
  539. C              skip blank card
  540.       READ(9,102,ERR=98)CARD
  541. C                  read the atom positions
  542.       DO 20 I=1,NPTS
  543.       READ(9,105,ERR=98)EL,X1,Y1,Z1
  544.   105 FORMAT(4X,A2,4X,3F10.5)
  545.       X(I)=X1*A
  546.       XC=XC+X(I)
  547.       Y(I)=Y1*B 
  548.       YC=YC+Y(I)
  549.       Z(I)=Z1*C 
  550.       ZC=ZC+Z(I)
  551.       IF(I.EQ.1)EL1=EL
  552.       J=0
  553.       IF(EL.EQ.EL1) J=1
  554.       KOL(I)=J
  555.    20 CONTINUE
  556.    90 CLOSE(9)
  557.       XC=XC/NPTS
  558.       YC=YC/NPTS
  559.       ZC=ZC/NPTS
  560.       DO 92 I=1,NPTS
  561.       X(I)=X(I)-XC
  562.       Y(I)=Y(I)-YC
  563.       Z(I)=Z(I)-ZC
  564.    92 CONTINUE
  565.       RETURN
  566.    98 PRINT 110,NPTS,CARD
  567.   110 FORMAT(' bad data, NPTS =',I4,' card is'/' ',A)
  568.       STOP 'bad read'
  569.    99 PRINT *,'can not read file ',NAME,' try another (T) or stop (S)'
  570.       IF(IG('TS').EQ.2)CALL QUIT
  571.       GO TO 10
  572.       END
  573.       SUBROUTINE RDshak
  574. C                                       COMMON BLOCK
  575.       PARAMETER(MXPNTS=99,ISPSIZ=40000)
  576.       COMMON IND(MXPNTS),X(MXPNTS),Y(MXPNTS),Z(MXPNTS),ISP(ISPSIZ),
  577.      2 KOL(MXPNTS),XP,YP,ZP,Z0,DS,ZMIN,ZMAX,ISH,MAXR,NSPRIT,MAXS,
  578.      3 IYBYX,MODES,MX,MY,MB,MXO,MYO,MBO,NPTS         
  579.       PARAMETER(SCALE=50.0)
  580.       CHARACTER CARD*72,EL*2,NAME*30
  581.       CALL MODE(MODES)
  582.       CALL GREYS
  583.       CALL ORIGIN (640,512 )
  584.       XC=0.
  585.       YC=0.
  586.       ZC=0.
  587. C                   show user possible files
  588.       CALL GETDIR('<SphR$Dir>','SH',N)
  589.       IF(N.LT.1)THEN
  590.         WRITE(*,*)' Sorry, no SH files in directory'
  591.         RETURN
  592.       ENDIF
  593.    10 PRINT 101
  594.   101 FORMAT($,'Schakal file name? ')
  595.       READ (*,102,ERR=10) NAME
  596.   102 FORMAT(A)
  597.       OPEN(9,FILE='<SphR$Dir>.'//NAME,STATUS='OLD',FORM='FORMATTED',
  598.      1 ERR=99)
  599. C         ignore the title card
  600.       READ(9,102,ERR=99,END=99)CARD
  601.    20 READ(9,102,ERR=98,END=90)CARD
  602.       IF(CARD(1:4).EQ.'CELL') THEN
  603.         READ(CARD(6:),105,ERR=98)A,B,C
  604.   105   FORMAT(3F9.3)
  605. C             A,B,C are unit cell size, now scale to screen
  606.         A=A*SCALE
  607.         B=B*SCALE
  608.         C=C*SCALE
  609.       ELSE IF(CARD(1:4).EQ.'ATOM') THEN
  610.         READ(CARD(6:),103,ERR=98)EL,X1,Y1,Z1
  611.   103   FORMAT(A2,2X,F7.4,F8.4,F9.4)
  612.         NPTS=NPTS+1
  613.         IF(NPTS.GT.MXPNTS) GO TO 80
  614.         X(NPTS)=X1*A
  615.         XC=XC+X(NPTS)
  616.         Y(NPTS)=Y1*B
  617.         YC=YC+Y(NPTS)
  618.         Z(NPTS)=Z1*C
  619.         ZC=ZC+Z(NPTS)
  620.         I=0
  621.         IF(EL.EQ.'O ') I=1
  622.         KOL(NPTS)=I
  623.       ELSE
  624.         IF(CARD(1:4).EQ.'END ') GO TO 90
  625.       ENDIF
  626.       GO TO 20
  627.    80 PRINT *,' max points exceeded'
  628.    90 CLOSE(9)
  629.       XC=XC/NPTS
  630.       YC=YC/NPTS
  631.       ZC=ZC/NPTS
  632.       DO 92 I=1,NPTS
  633.       X(I)=X(I)-XC
  634.       Y(I)=Y(I)-YC
  635.       Z(I)=Z(I)-ZC
  636.    92 CONTINUE
  637.       RETURN
  638.    98 PRINT 104,NPTS,CARD
  639.   104 FORMAT(' bad data, NPTS =',I4,' card is'/' ',A)
  640.       STOP 'bad read'
  641.    99 PRINT *,'can not read file ',NAME,' try another (T) or stop (S)'
  642.       IF(IG('TS').EQ.2)CALL QUIT
  643.       GO TO 10
  644.       END
  645.       FUNCTION IG(CHR)
  646.       CHARACTER*(*) CHR
  647.       PRINT 101,CHR
  648.   101 FORMAT($,'(',A,')? ')
  649.    10 I=IGET()
  650.       IF(I.EQ.27) STOP 'Escape'
  651.       IF(I.GT.96) I=I-32
  652.       IG=INDEX(CHR,CHAR(I))
  653.       IF(IG.EQ.0) GO TO 10
  654.       PRINT 102,CHR(IG:IG)
  655.   102 FORMAT(A)
  656.       RETURN
  657.       END
  658.       SUBROUTINE QUIT
  659. C                                       COMMON BLOCK
  660.       PARAMETER(MXPNTS=99,ISPSIZ=40000)
  661.       COMMON IND(MXPNTS),X(MXPNTS),Y(MXPNTS),Z(MXPNTS),ISP(ISPSIZ),
  662.      2 KOL(MXPNTS),XP,YP,ZP,Z0,DS,ZMIN,ZMAX,ISH,MAXR,NSPRIT,MAXS,
  663.      3 IYBYX,MODES,MX,MY,MB,MXO,MYO,MBO,NPTS         
  664.       CALL MODE(MODES)
  665. C                  put cursor keys back to arrow operation
  666.       CALL OSBYTE(4,0,0)
  667.       CALL OSBYTE(11,32,0)
  668. C                             put    MOUSE STEP back to 2
  669.       CALL OSWORD(21,?I020202)
  670.       STOP'OK'
  671.       END
  672.       SUBROUTINE GETDIR(DIR,STR,N)
  673. C          uses SWIF77 with OS_GBPB to read and print file names in 
  674. C          directory DIR which contain the string STR, returns N number found
  675.       CHARACTER * (*) DIR,STR
  676.       CHARACTER *50 BIR,BTR
  677.       CHARACTER *12 FNAME
  678.       DIMENSION IREGS(0:7)
  679.       LOGICAL SWIF77
  680. C
  681.       I=LNBLNK(DIR)
  682.       BIR(1:I)=DIR(1:I)
  683.       N=0
  684.       IREGS(0)=9       
  685.       IREGS(1)=LOCC(BIR//?H00)
  686.       IREGS(2)=LOCC(FNAME)
  687.       IREGS(3)=1
  688.       IREGS(4)=0
  689.       IREGS(5)=11
  690.       IREGS(6)=0
  691.       WRITE(*,*)' files in ',DIR,' are:'
  692.       J=LNBLNK(STR)
  693.       BTR(1:J)=STR(1:J)
  694.     2 IF(SWIF77(?I0C,IREGS,IFLAG)) GO TO 90
  695.       IF(IREGS(4).LT.0) GO TO 4
  696.       IF(IREGS(3).LE.0) GO TO 2  
  697.       I=INDEX(FNAME,?H00)
  698.       IF(INDEX(FNAME(1:I-1),BTR(1:J)).EQ.0) GO TO 2
  699.       WRITE(*,*)FNAME(1:I-1)
  700.       N=N+1
  701.       GO TO 2
  702.     4 WRITE(*,*)' number of files = ',N
  703.       RETURN
  704.    90 WRITE(*,*)' error reading file names after ',N
  705.       STOP 'FAIL'
  706.       END
  707.