SUBROUTINE NEWQUAD C*BEGIN COMMON COMMON SNAP,SNAPSHT(226), + DATE,REMKL,REMCOM,REMBASE,REMRES,REMTIME,STARKL,BASEKL, + KILLK,KILLC,GALAXY(8,8),CX(10),CY(10),BASEQX(5),BASEQY(5), + NEWSTUF(8,8),PLNETS(10,5),ISX,ISY,NSCREM,NROMKL,NROMREM, + NSCKILL,ICRYSTL,NPLANKL, + QUAD(10,10),KX(20),KY(20),KPOWER(20),KDIST(20),KSTUF(20), + INKLING,INBASE,INRESOR,INCOM,INTIME,INSTAR,INENRG,INSHLD, + INTORPS,INLSR,INDATE,ENERGY,SHLD,SHLDUP,CONDIT,TORPS,SHIP, + QUADX,QUADY,SECTX,SECTY,WARPFAC,WFACSQ,LSUPRES,DAMAGE(20), + LENGTH,SKILL,PASSWD,DIST,DIREC,TIME,BASEX,BASEY,DOCKFAC, + KLHERE,COMHERE,CASUAL,NHELP,NKINKS,STARCH(8,8),FUTURE(10), + DEVICE(2,14),IDIDIT,GAMEWON,ALIVE,JUSTIN,RESTING,ALLDONE, + DAMFAC,SHLDCHG,THINGX,THINGY,NDEVICE,PLNETX,PLNETY,INORBIT, + LANDED,IPLANET,IMINE,INPLAN,NENHERE,ISHERE,NEUTZ,IRHERE,ICRAFT, + IENTESC,ISCRAFT,ISATB,ISCATE,CRYPROB,ICITE,IPHWHO,BATX,BATY, + CRACKS(12) INTEGER CF,CI,SHLDUP,CONDIT,QUADX,QUADY,SECTX,SECTY,TORPS, + REMKL,REMBASE,SKILL,REMCOM,GALAXY,STARCH,CX,CY, + SHIP,ALLDONE,BASEQX,BASEQY,BASEX,BASEY,GAMEWON, + ALIVE,STARKL,BASEKL,CASUAL,COMHERE,RESTING,SNAP,SHLDCHG, + THINGX,THINGY,BATX,BATY,PLNETX,PLNETY,PLNETS REAL KDIST,KPOWER,LSUPRES,INTIME,INRESOR,INDATE,INSHLD, + INENRG,INLSR BYTE QUAD REAL*8 DEVICE,PASSWD C*END COMMON LOGICAL*1 IHS,IHR,IHC,IHK,IHE,IHF,IHBLANK,IHDOT,IHP,IHB 1 ,IHSTAR,IHT,IHQUEST,IHNUM,ISHIP COMMON/HOLLER/IHEOL,IHREAL,IHALPHA,IHS,IHR,IHC,IHK,IHGREEN,IHRED, +IHYELLO,IHDOCKD,IHE,IHF,IHBLANK,IHDOT,IHQUEST,IHP,IHSTAR,IHB +,IHT,IHNUM INTEGER QUADNUM REAL*8 THOLIANX EQUIVALENCE (CRACKS(2),SHUTUP),(SHIP,ISHIP) EQUIVALENCE (KSTUF(1),ITHERE),(KSTUF(2),ITHX),(KSTUF(3),ITHY) BYTE IHX DATA IHX/'X'/ DATA THOLIANX/8HTHOLIANX/ JUSTIN=1 BASEX=0 BASEY=0 KLHERE=0 COMHERE=0 PLNETX=0 PLNETY=0 ISHERE=0 IRHERE=0 IPLANET=0 NENHERE=0 NEUTZ=0 INORBIT=0 LANDED=-1 IENTESC=0 ITHERE=0 IF(ISCATE .EQ. 0) GO TO 5 C--------ENTERPRISE TRIED TO ESCAPE FROM A SUPER-COMMANDER. ISCATE=0 IENTESC=1 5 QUADNUM=GALAXY(QUADX,QUADY) IF(QUADNUM .GT. 999) GO TO 70 KLHERE=QUADNUM/100 NEWNUM=NEWSTUF(QUADX,QUADY) IRHERE=NEWNUM/10 NPLAN=NEWNUM-IRHERE*10 NENHERE=KLHERE+IRHERE C--------EMPTY QUADRANT AND POSITION STARSHIP DO 15 I=1,10 DO 15 J=1,10 15 QUAD(I,J)=IHDOT QUAD(SECTX,SECTY)=ISHIP C-----------DECIDE IF THIS QUADRENT NEEDS A THOLIAN..... IF((RANF(0).GT.0.08).AND.(PASSWD.NE.THOLIANX)) GO TO 23 C--------DECIDE POSITION FOR THOLIAN...... 17 ITHX=INT(RANF(0)+0.5)*9+1 ITHY=INT(RANF(0)+0.5)*9+1 IF(QUAD(ITHX,ITHY).NE.IHDOT) GO TO 17 QUAD(ITHX,ITHY)=IHT ITHERE=1 C---------PUT AN X IN EACH UNOCCUPIED CORNER. (TO RESERVE IT) IF(QUAD(1,1).EQ.IHDOT) QUAD(1,1)=IHX IF(QUAD(1,10).EQ.IHDOT)QUAD(1,10)=IHX IF(QUAD(10,10).EQ.IHDOT)QUAD(10,10)=IHX IF(QUAD(10,1).EQ.IHDOT)QUAD(10,1)=IHX 23 CONTINUE C--------POSITION ORDINARY KLINGON VESSELS IF(QUADNUM .LT.100)GO TO 34 QUADNUM=QUADNUM-100*KLHERE DO 25 I=1,KLHERE CALL DROPIN(IHK,IX,IY) KX(I)=IX KY(I)=IY 25 KPOWER(I)=RANF(0)*150.0+300.+25.*SKILL C--------IF THIS QUADRANT NEEDS A COMMANDER, PROMOTE ONE KLINGON IF(REMCOM .EQ. 0) GO TO 32 DO 30 I=1,REMCOM IF(CX(I) .EQ. QUADX .AND. CY(I) .EQ. QUADY)GO TO 31 30 CONTINUE GO TO 32 31 QUAD(IX,IY)=IHC KPOWER(KLHERE)=950.0+400.0*RANF(0)+50.*SKILL COMHERE=1 COMX=IX COMY=IY C--------IF THIS QUADRANT NEEDS A SUPER-COMMANDER, PROMOTE ONE KLINGON. 32 I=KLHERE IF((QUADX .NE. ISX) .OR. (QUADY .NE. ISY)) GO TO 34 IF(COMHERE .EQ. 0) GO TO 33 I=KLHERE-1 IX=KX(I) IY=KY(I) 33 QUAD(IX,IY) = IHS KPOWER(I)=1175.0+400.0*RANF(0)+125.0*SKILL ISCATE=1 ISHERE=1 C--------PUT IN ROMULANS IF NEEDED. 34 IF(IRHERE .EQ. 0) GO TO 37 ITEMP1=KLHERE+1 DO 36 I=ITEMP1, NENHERE CALL DROPIN(IHR,IX,IY) KX(I)=IX KY(I)=IY 36 KPOWER(I)=450.+400.*RANF(0)+50.*SKILL 37 CALL RESETD CALL SORTKL C--------IF QUADRANT CONTAINS A STARBASE, CHOOSE ITS POSITION IF(QUADNUM .LT. 10)GO TO 50 QUADNUM =QUADNUM - 10 CALL DROPIN(IHB,BASEX,BASEY) C--------IF QUADRANT NEEDS A PLANET, PUT ONE IN. 50 IF(NPLAN .EQ. 0) GO TO 54 DO 51 I=1,INPLAN IPLANET=I IF(PLNETS(I,1) .EQ. QUADX .AND. PLNETS(I,2) .EQ. QUADY) GO TO 52 51 CONTINUE IPLANET=0 GO TO 54 52 CALL DROPIN(IHP,PLNETX,PLNETY) C--------AND FINALLY, THE STARS 54 CALL NEWCOND IF(QUADNUM .LT. 1)GO TO 62 DO 60I=1,QUADNUM 60 CALL DROPIN(IHSTAR,IX,IY) C--------IF ROMULANS PRESENT WITHOUT KLINGONS OR BASE, PRINT SPECIAL MESSAGE. 62 IF((IRHERE .EQ. 0) .OR. (KLHERE .NE. 0) .OR. (BASEX .NE. 0))GOTO66 IF(DAMAGE(9) .GT. 0.) GO TO 64 CALL SKIP(1) CALL PROUT(41HLT. UHURA: "CAPTAIN, AN URGENT MESSAGE. ,41) CALL PROUT(31H I'LL PUT IT ON AUDIO." CLICK ,31) CALL SKIP(1) CALL PROUT(58H "INTRUDER! YOU HAVE VIOLATED THE ROMULAN NEUTRAL CZONE." ,58) CALL PROUT(44H "LEAVE AT ONCE, OR YOU WILL BE DESTROYED!" ,44) 64 NEUTZ=1 C--------PUT IN "THING" IF NEEDED 66 IF(SHUTUP.NE.0.) GO TO 67 IF(THINGX.NE.QUADX .OR. THINGY.NE.QUADY) GO TO 67 CALL DROPIN(IHQUEST,IX,IY) THINGX=0 THINGY=0 IF(DAMAGE(1)) GO TO 67 CALL SKIP(1) CALL PROUT( + 43HMR. SPOCK: "CAPTAIN, THIS IS MOST UNUSUAL.,43) CALL PROUT( + 43H PLEASE EXAMINE YOUR SHORT-RANGE SCAN.",43) C--------DROP IN A FEW BLACK HOLES 67 DO 68 I=1,3 68 IF(RANF(0) .GT. 0.89) CALL DROPIN(IHBLANK,IX,IY) C----------IF THOLIAN HERE, TAKE THE X OUT OF EACH CORNER. IF(ITHERE.EQ.0) RETURN IF(QUAD(1,1).EQ.IHX) QUAD(1,1)=IHDOT IF(QUAD(1,10).EQ.IHX)QUAD(1,10)=IHDOT IF(QUAD(10,10).EQ.IHX)QUAD(10,10)=IHDOT IF(QUAD(10,1).EQ.IHX) QUAD(10,1)=IHDOT RETURN C--------COPE IF QUADRANT CONTAINS ONLY A SUPERNOVA 70 DO 75 I=1,10 DO 75 J=1,10 75 QUAD(I,J)=IHDOT RETURN END