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