C @(#)planbot.for 17.1.1.1 (ES0-DMD) 01/25/02 17:17:33 C=========================================================================== C Copyright (C) 1995 European Southern Observatory (ESO) C C This program is free software; you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation; either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a copy of the GNU General Public C License along with this program; if not, write to the Free C Software Foundation, Inc., 675 Massachusetss Ave, Cambridge, C MA 02139, USA. C C Corresponding concerning ESO-MIDAS should be addressed as follows: C Internet e-mail: midas@eso.org C Postal address: European Southern Observatory C Data Management Division C Karl-Schwarzschild-Strasse 2 C D 85748 Garching bei Muenchen C GERMANY C=========================================================================== C SUBROUTINE PLANBOT(DJS,LASTD,NSTARS,NEEDST,JSYS,DRAT,BANDS,SALTS, 1 PLACE,TELCM,TL,ITIME,ZONE) C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C.COPYRIGHT (c) Andrew T. Young, 1990 C.COPYRIGHT (c) European Southern Observatory, 1992 C.IDENT program plan C.MODULE planbot.for C.AUTHOR Andrew T. Young C.KEYWORD C.LANGUAGE FORTRAN 77 C.PURPOSE Makes a photometric observing schedule C.COMMENTS C.VERSION 4.5 C.RETURNS error numbers correspond to nearby statement numbers C.ENVIRONMENT MIDAS C----------------------------------------------------------------------------- C C Second half of old "plan" program. C C Copyright (C) by Andrew T. Young, 1990 C C IMPLICIT NONE C C *** SYSTEM-DEPENDENT FEATURES ARE FLAGGED BY *** COMMENTS LIKE THIS. C C F I L E S : C ----------- C CHARACTER*80 DATFIL C *** LENGTH OF FILE NAMES MAY BE SYSTEM-DEPENDENT. C FULL SET FOR SUBROUTINE COMPATIBILITY. INTEGER KB, KTV, K2, K3, K4, K7, K8, K9 COMMON /FILNOS/ KB, KTV, K2, K3, K4, K7, K8, K9 C *** UNITS MAY BE SYSTEM-DEPENDENT. C C C N A M I N G C O N V E N T I O N S : C ------------------------------------ C EXTERNAL NAME SAMPLE C QUANTITY VARIABLE TYPE FOR DATA FILE VALUE C -------- -------- ---- ------------- ------ C C NAMES: C C PLACE NAME PLACE CH*20 KITT PEAK C BAND NAME BAND CH*6 C STAR NAME STAR CH*20 STAR HR 8832 C STAR CODE STRCDS CH*20 STARCD 17 C INDICES CNAMES(1,NB) CH*6 V, B-V, M1, ... -0.20 C GAIN CONTROL GCONTR(NGAIN) CH*20 COARSE C GAIN SETTING GANCOD(I,N) CH*20 GAINS1, ... ,GAINS4 2 C C COORDINATES IN RADIANS: C C LONGITUDE ELONG REAL C LATITUDE ALAT REAL C HOUR ANGLE HA REAL C RIGHT ASCENSION RA REAL C DECLINATION DEC REAL C UNIVERSAL TIME UT REAL C ZONE TIME ZT REAL C SIDEREAL TIME ST REAL C C EXTERNAL SUB-UNITS ARE NAMED AS FOLLOWS: TYPE C ---- C DEGREES 1ST 2 LETTERS OF REAL VARIABLE//'DEG' REAL C HOURS " " " " " " //'HRS' REAL C MINUTES " " " " " " //'MIN' REAL C SECONDS " " " " " " //'SEC' REAL C C SPECIAL FORMS: C ROTATIONS " " " " " " //'ROT' REAL C CHAR.STRING " " " " " " //'STR' CHARACTER*20 C SIGN " " " " " " //'SGN' CHARACTER*20 C C EXAMPLES: RAHRS, UTMIN, ELSEC, ALDEG, DESTR, DESGN C C C P E P S Y S S Y S T E M V A R I A B L E S C --------------------------------------------- C INTEGER MOBS PARAMETER (MOBS=10) CHARACTER *20 PLACE C INCLUDE 'MID_REL_INCL:mstars.inc' C PARAMETER (MSTARS=1650) C commons for star catalog: CHARACTER *32 STARS COMMON /SCATA/ STARS(MSTARS) REAL RAS, DECS, EQUINX, COLORS COMMON /SCAT/ RAS(MSTARS), DECS(MSTARS), EQUINX(MSTARS), COLORS C C CAUTION -- MBANDS IS IN SUBROUTINES RDLIST, OPNFIL, DECOLR, & EPHEM. INCLUDE 'MID_REL_INCL:mbands.inc' C PARAMETER (MBANDS=9) REAL COLORM, COLRIN, XINV,YINV INTEGER NBANDS,LENB,LENC,KX,KY COMMON /CMAGS1/ COLORM(MBANDS,MBANDS),COLRIN(MBANDS,MBANDS), 1 XINV,YINV,NBANDS,LENB,LENC,KX,KY C REAL PHOMAG,FAINTS,BRITES,SZMAX, 1 SZMIN,EXTIN,SIGTOT,TINT1,TSUGG COMMON /CMAGS2/PHOMAG(MBANDS),FAINTS(MBANDS),BRITES(MBANDS),SZMAX, 1 SZMIN,EXTIN(MBANDS),SIGTOT,TINT1,TSUGG SAVE /CMAGS1/,/CMAGS2/ C CHARACTER *8 BANDS(3*MBANDS), CNAMES(2,MBANDS) DIMENSION COLORS(MBANDS,MSTARS) INTEGER MBM1,MBM2,MBM3,MBM4,MBM5,MBM6,MBM7 PARAMETER(MBM1=MBANDS-1,MBM2=MBANDS-2,MBM3=MBANDS-3,MBM4=MBANDS-4) PARAMETER(MBM5=MBANDS-5,MBM6=MBANDS-6,MBM7=MBANDS-7) C INTEGER MSYS PARAMETER (MSYS=8) C C C PARAMETERS FOR RDLIST/RDBLOK. C INTEGER MGAINS,MG2,MA,MCAT,MN,MV,MGRPS,MAREST,MNREST PARAMETER (MGAINS=4, MG2=2*MGAINS) PARAMETER (MA=21+MG2+5) PARAMETER (MCAT=12+2*MBANDS,MN=MCAT+30, MV=MA+MN, MGRPS=8) PARAMETER (MAREST=MA-21-MG2, MNREST=MN-MCAT-15) C C MA = MAX. ALPHABETIC (CHARACTER) VARIABLES, AVAR IN /NAMES/ C MN = MAX. NUMERIC VARIABLES, VAR IN /VALUES/ C MV = MAX. VARIABLE NAMES, NAMES IN /NAMES/ C C COMMONS FOR RDLIST/RDBLOK. NOTE RENAMING OF ELEMENTS OF AVAR. C C THESE MA CHARACTER VARIABLES REPLACE AVAR(MA): C CHARACTER NAMES(MV)*6,TITLE*80, AVAR(MA)*20 <--REPLACED BY LIST. C CHARACTER NAMES(MV)*6,TITLE*80 CHARACTER*32 STAR CHARACTER*20 RASTR,DESTR,BAYER,CONSTL,FLAMST,BSHR,HD,DM, 1 SPECT,DESGN,DATSTR,MONTH,REM1,REM2,STSTR,ZTSTR,UTSTR, 2 FILTCD,STARCD,STRSKY,ASPARE(MAREST),GANCDN(MGAINS),DIMCDN(MGAINS) C C COMMON /NAMES/NAMES,TITLE, AVAR COMMON /NAMES/NAMES,TITLE, RASTR,DESTR,STAR,BAYER,CONSTL,FLAMST, 1 BSHR,HD,DM,SPECT,DESGN,DATSTR,MONTH,REM1,REM2,STSTR,ZTSTR,UTSTR, 2 FILTCD,STARCD,STRSKY,ASPARE,GANCDN,DIMCDN EQUIVALENCE (CNAMES,NAMES(13)) C 13 BECAUSE CVARS IS VAR(13). C C REAL VARIABLES THAT REPLACE VAR(MN): C COMMON /VALUES/ NAM1(MGRPS),NAM2(MGRPS),NGRPS,VAR(MN) C INTEGER NAM1,NAM2,NGRPS,MURAT,MURAA,MUDEC REAL RAHRS,RAMIN,RASEC, 1 DEDEG,DEMIN,DESEC,EPOCH,SIGNAL,TINT, 2 CVARS,FMM,DD,YY,YEAR,DAY, 3 UTHRS,UTMIN,UTSEC,CLKERR,STHRS,STMIN,STSEC, 4 ZTHRS,ZTMIN,ZTSEC,VSPARE COMMON /VALUES/ NAM1(MGRPS),NAM2(MGRPS),NGRPS,RAHRS,RAMIN,RASEC, 1 DEDEG,DEMIN,DESEC,EPOCH,MURAT,MURAA,MUDEC,SIGNAL,TINT, 2 CVARS(2,MBANDS),FMM,DD,YY,YEAR,DAY, 3 UTHRS,UTMIN,UTSEC,CLKERR,STHRS,STMIN,STSEC, 4 ZTHRS,ZTMIN,ZTSEC,VSPARE(MNREST) C C C COMMONS FOR SPHERICAL TRIG.: C REAL SINPHI,COSPHI,ELONG,ELROT,UTROT,STUTZ,TWOPI,ST2UT, 1 TNOON1,TNOON2,PI,DEGRAD,ALAT COMMON /SPHERE/ SINPHI,COSPHI,ELONG,ELROT,UTROT,STUTZ,TWOPI,ST2UT, 1 TNOON1,TNOON2,PI,DEGRAD,ALAT C C COMMONS FOR SUN. C REAL COSOB,SINOB,RASUN,DESUN,HASUN,SOLONG,ELMOON,BMOON COMMON /CSUN/ COSOB,SINOB,RASUN,DESUN,HASUN,SOLONG,ELMOON,BMOON C C CAUTION -- THESE APPEAR IN SUBROUTINE FILL ALSO: INTEGER MSET,MROOM,MSG,MTIM PARAMETER (MSET=MSTARS-100,MROOM=2,MSG=14,MTIM=MROOM*MSET+MSG) C C MSET IS MAX.LENGTH OF SUBSET CHOSEN FOR EXT./STD. STARS. C MTIM IS MAX.LENGTH OF EVENT TIMES. C SAVE /CFILL/,/SPHERE/,/CSUN/,/HELPS/ C REAL UTBGN,UTEND,DARKT,TIMES INTEGER NOBJS,NT COMMON /CFILL/ UTBGN,UTEND,DARKT,TIMES(MTIM),NOBJS(MTIM),NT C C TIMES(NT) IS EVENT TIME IN SCHEDULE. C NOBJS(NT) IS OBJECT NUMBER IN SUBSET OF EXT./STD.STARS. C C COMMON FOR HELP COUNT: COMMON /HELPS/ NEEDH,NASSMP CHARACTER ASSMPS(8)*40,ASSUME(8)*40 COMMON /ASSUME/ ASSMPS,ASSUME CHARACTER*13 F361 COMMON /FMT361/ F361 CHARACTER*79 PAGE(21) COMMON /SCREEN/PAGE INTEGER JCONT,JLOG,JDISP COMMON /FLAGS/JCONT,JLOG,JDISP C LOGICAL PC,DC,CI,NEEDIM,CODEDS,DARK,FUNK,FCORN, 1 COOLED C COMMON /LOGIC/ NEEDED,DIMMED,PC,DC,CI,NEEDIM,CODEDS,DARK,FUNK, 1 FCORN,COOLED C C C CODEDS IS.TRUE.IF STARS ARE CODED IN DATA. C PC IS.TRUE.IF DATA ARE PULSE COUNTS. C DC IS.TRUE.IF DATA ARE CURRENTS. C CI IS.TRUE.IF DATA ARE CHARGE INTEGRATIONS. C CANNED IS.TRUE.IF PLACE OR STDFIL IS BUILT-IN. C NEEDIM IS.TRUE.IF OPTICAL DIMMER IS NEEDED. C MOVING IS.TRUE.IF EPHEMERIS OBJECTS EXIST. C C C L O C A L V A R I A B L E S C ----------------------------- C CHARACTER A,DMS*32,TL*4,FL(2)*5, 1 TWILIT(MSG+2)*27,IDS(MTIM)*8,OSTAR*32,FF, 2 DAT*30,ELABEL(2)*8,WLABEL(2)*8,ASSUM4(2)*40,ASSUM6(2)*40 EQUIVALENCE (ASSUM4,ASSUME(4)),(ASSUM6,ASSUME(6)) CHARACTER TEMPRH*34, RALBL*22,DECLBL*7 C C MSET IS MAX.LENGTH OF SUBSET CHOSEN FOR EXT./STD. STARS. STORAGE: C C NCAT(NOBJ) IS STAR-CATALOG INDEX OF OBJECT NOBJ IN SUBSET. C KTYPE(NOBJ) IS TYPE OF OBJECT. C C XS(NOBJ) & YS(NOBJ) ARE PLOTTING ARRAYS. C REAL SALTS, DJS, XS,YS, RALIMS,DECLIM,REDS,BLUES INTEGER KTYPE DIMENSION SALTS(MSG),DJS(2),NCAT(MSET),XS(MSET),YS(MSET), 1 KTYPE(MSET),RALIMS(2),DECLIM(2),REDS(2),BLUES(2) C C LOGICAL REDUCD,NEEDED,BAD,DIMMED C INTEGER LASTD, NSTARS, NEEDST, JSYS, ITIME, 1 NEEDH, NASSMP, 2 NCAT, J, LD, NDIG, I, NEEDEX, NEEDS, NEXCES, NSET, 3 NUMEXT, NB, K, NOBJ, NTYPE, N, NIGHT, LOOP, I1, NTIMES, 4 LPP, LINE C REAL DRAT, TELCM, ZONE, DJ, 1 DAYN, T, OLDEQ, DATEP, OBLIQ, COSMIN, ZDMIN, SINDH, DH, STBGN, 2 RABGN, STEND, RAEND, DELMAX, DELMIN, DEXMAX, DEXMIN, DUM, 3 COSANG, AMAG, STZROT, PHASE, DMAG, SIND, COSD, COSZ, ARG, 4 OLDCOS, RA, DEC, COSHA, HA, UT2ST C C CHARACTER FCNS.: C ---------------- CHARACTER DEG2MS*13, DEG2M1*8 C C LOGICAL FCNS.: C ------------- LOGICAL HELP C C INTEGER FCNS.: C ------------- INTEGER LWORD C C C D A T A : C --------- C C NUMERICAL VARIABLE NAMES ... (REALLY IN BLOCK DATA) C C NAMX() = 1 2 3 4 5 6 7 C DATA NAMES/'RAHRS','RAMIN','RASEC','DEDEG','DEMIN','DESEC','EPOCH' C C 8 9 10 11 12 C 1,'MURAT','MURAA','MUDEC','SIGNAL','TINT', C C 13 TO MCAT.... +1 +2 +3 +4 +5 C 2 MBANDS*' ',MBANDS*' ','MM','DD','YY','YEAR','DAY', C C MCAT + 6 +7 +8 +9 +10 +11 +12 C 3 'UTHRS','UTMIN','UTSEC','CLKERR','STHRS','STMIN','STSEC', C C MCAT+13 +14 +15 +16 TO MCAT +30 C 4 'ZTHRS','ZTMIN','ZTSEC', MNREST*' ', C C CHARACTER VARIABLE NAMES... C C MN+1 MN+2 MN+3 MN+4 MN+5 MN+6 MN+7 MN+8 MN+9 C 5 'RASTR','DESTR','STAR','BAYER','CONSTL','FLAMST','BSHR','HD','DM' C C MN+10 MN+11 MN+12 MN+13 MN+14 MN+15 MN+16 MN+17 C 6 ,'SPECT','DESGN','DATSTR','MONTH','REM1','REM2','STSTR','ZTSTR', C C MN+18 MN+19 MN+20 MN+21 MN+22 TO C 7 'UTSTR','FILTCD','STARCD','STRSKY',MGAINS*' ',MGAINS*' ', C C MN+ C 8 MAREST*' '/ C C C C SYSTEM DATA: C C DATA SYSTMS/'UBV','UBVRI','UVBY','H-BETA','UVBYHB','GENEVA','DDO', C 1 'OTHER'/ C DATA JBANDS/ 3, 5, 4, 2, 6, 7, 6, C 1 0/ C C DATA STDFLS/'UBVSTD','UBVSTD','UVBYST','UVBYST','UVBYST','GENSTD', C 1 'DDOSTD',' '/ C C DATA LENBS/2,2,1,6,6,2,2,1/,LENCS/3,3,3,4,4,5,6,0/ C C BAND NAMES. C DATA BNDS/'U','B','V','RL',MBM4*' ', C 2 'U','B','V','R','I','RL',MBM6*' ', C 3 'U','V','B','Y',MBM4*' ', C 4 'WIDE','NARROW',MBM2*' ', C 5 'U','V','B','Y','WIDE','NARROW',MBM6*' ', C 6 'U','B','V','B1','B2','V1','G',MBM7*' ', C 7 '48','45','42','41','38','35',MBM6*' ' ,MBANDS*' '/ C C MAGNITUDE AND COLOR NAMES FOR EXTERNAL LISTS. C DATA BNDVAR/'V','U-B','B-V',MBM3*' ', C 2 'V','U-B','B-V','V-R','R-I',MBM5*' ', C 3 'V','B-Y','M1','C1',MBM4*' ', C 4 'BETA','M4861',MBM2*' ', C 5 'V','B-Y','M1','C1','BETA','M4861',MBM6*' ', C 6 'VM','U-B','B-V','U-B2','B1-B2','B2-V1','V1-G',MBM7*' ', C 7 'M48','C45-48','C42-45','C41-42','C38-41','C35-38',MBM6*' ', C 8 MBANDS*' '/ C C EFF.WAVELENGTHS. C UBV:BUSER,A.&AP.62,411(1979); OTHERS FROM DUDLEY OBS.REPT. C DATA STDWLS/3652.,4417.,5505.,7000.,MBM4*0., C 2 3652.,4417.,5505.,6400.,8000.,7000.,MBM6*0., C 3 3425.,4110.,4670.,5510.,MBM4*0., C 4 4861.,4861.,MBM2*0., C 5 3425.,4110.,4670.,5510.,4861.,4861.,MBM6*0., C 6 3458.,4248.,5508.,4022.,4480.,5408.,5814.,MBM7*0., C 7 4886.,4517.,4257.,4166.,3815.,3460.,MBM6*0. ,MBANDS*0./ C C WIDTHS. THESE ARE ABOUT 2.64 X MU2. C DATA FWHMS/535.,980.,800.,300.,MBM4*0., C 2 535.,980.,800.,1400.,1700.,600.,MBM6*0., C 3 375.,200.,175.,250.,MBM4*0., C 4 150.,30.,MBM2*0., C 5 375.,200.,175.,250.,150.,30.,MBM6*0., C 6 450.,800.,800.,450.,440.,530.,540.,MBM7*0., C 7 186.,76.,73.,83.,330.,383.,MBM6*0. ,MBANDS*0./ C PEAK TRANSMISSIONS. C DATA TRANSS/.86,.73,.9,.9,MBM4*0., C 2 .86,.73,.9,.77,.86,.9,MBM6*0., C 3 .39,.49,.48,.53,MBM4*0., C 4 .75,.6,MBM2*0., C 5 .39,.49,.48,.53,.75,.6,MBM6*0., C 6 .65,.65,.5,.5,.34,.3,.3,MBM7*0., C 7 .56,.55,.53,.49,.65,.41,MBM6*0., MBANDS*0./ C C 2-COLOR DIAGRAMS. O C U U B 4 G T C U . V E + E D H C B . B T H N D E C V I Y A B V O R C DATA KYS /2, 2, 4, 0, 4, 4, 2, 0/ C DATA KXS /3, 3, 2, 0, 2, 6, 3, 0/ C DATA YINVS/1.,1.,0.,0.,0.,1.,0.,0./ C DATA XINVS/0.,0.,0.,0.,0.,0.,0.,0./ C C DATA FL/'FIRST',' LAST'/ C C DATA FOR SUN/MOON SET/RISE AND TWILIGHTS: (set in plantop) C C DATA SALTS/-.0145,-.1045,-.208,-.309,-.309,-.208,-.1045,-.0145, C SUN ABOVE, MOON BELOW. C 1 -.0145,-.0145,-.12,-.12,+.3,+.3/ C DATA TWILIT/'SUN SETS','END CIVIL TWILIGHT', 1 'END NAUTICAL TWILIGHT' 2,'END ASTRONOMICAL TWILIGHT','BEGIN ASTRONOMICAL TWILIGHT', 3'BEGIN NAUTICAL TWILIGHT','BEGIN CIVIL TWILIGHT','SUN RISES', C 4'MOONRISE - FAST SKY CHANGES','MOONSET -- SKY CHANGES FAST', 5'BEGIN LUNAR TWILIGHT','END LUNAR TWILIGHT', 6'SKY CHANGES MORE SLOWLY','BEGIN RAPID SKY CHANGES', 7'CHECK DARK LEVEL', 'BE SURE COOLING IS ON'/ C DATA ELABEL/' RISING',' EAST'/,WLABEL/' SETTING',' WEST'/ C DATA DECLBL/' DEC.'/, 1 TEMPRH/'TEMP.= R.H. = U.T. ='/, 2 RALBL/' <---- R.A. '/ C DATA RALIMS/24.,0./,DECLIM/0.,0./ C C C...................... EXECUTION resumes HERE ............................... C C C DJ IS JULIAN DATE FOR 0.HOURS U.T. C DJ=DJS(1)+(INT(DJS(2)-DJS(1))/2) C PICK DAY IN MIDDLE OF RUN. CALL JD2DAT(DJ,DAT) PAGE(1)='MIDDLE U.T. DATE = '//DAT CALL TV(PAGE(1)) C CREATE DATFIL. IF(CODEDS)THEN J=5 IF(DAT(5:5).EQ.' ')J=6 LD=12-J DATFIL=DAT(:3)//DAT(J:6)//'ID' OPEN(K7,FILE=DATFIL,STATUS='UNKNOWN') END IF OPEN(K9,FILE='PROUT',STATUS='UNKNOWN') CALL REHEAD(NDIG,DAT,CODEDS) C hope we use ASCII collating sequence... FF=CHAR(12) C DAYN=DJ-2451545.0 C DAYS FROM J2000.0 (SEE P.C24 OF 1984 A.A.). T=DAYN/36525. C C PRECESS STARS HERE. C OLDEQ=0. DATEP=2000.+T*100. DO 325 I=1,NSTARS IF(EQUINX(I).EQ.3.E33)THEN C MISSING EPOCH. IF(OLDEQ.EQ.0.)CALLTV('NO START EPOCH; stars cannot be precessed.' 1) OLDEQ=3.E33 GO TO 324 END IF C Data referred to equinox of date: IF(EQUINX(I).EQ.0.)GOTO 325 C PRECESS. IF(EQUINX(I).NE.OLDEQ)THEN C SET UP NEW INTERVAL. CALL PRECEP(EQUINX(I),DATEP,RAS(I),DECS(I)) OLDEQ=EQUINX(I) ELSE C USE OLD INTERVAL. CALL PRECST(RAS(I),DECS(I)) END IF 324 EQUINX(I)=DATEP 325 CONTINUE C IF(OLDEQ.NE.3.E33)THEN WRITE(PAGE,328)DATEP CALL TV(PAGE(1)) CALL TVN(' ') WRITE(K9,328)DATEP 328 FORMAT(14X,'STARS HAVE BEEN PRECESSED TO',F9.2/) END IF OBLIQ=(23.43929-T*(1.30042E-2+T*(1.639E-7-T*5.036E-7)))*DEGRAD COSOB=COS(OBLIQ) SINOB=SIN(OBLIQ) C SET STUTZ (RADIANS). CALL STUTZR(T) C 330 SZMIN=1.1 REDUCD=.FALSE. C C HERE after SZMIN reset. 331 IF(SZMIN.GT.1.2)WRITE(ASSUME(8),'(11X,''MIN.SEC Z ='',F6.3)')SZMIN COSMIN=1./SZMIN ZDMIN=ACOS(COSMIN) SINDH=SIN(ZDMIN)/COSPHI C IF(SINDH.LE.1.)THEN C DH is the hour angle tangent to SZMIN almucantar. DH=ASIN(SINDH) ELSE C DH flags limit. DH=TWOPI END IF C C C Find STBGN,STEND & RABGN, RAEND. DO 340 I=3,6,3 CALL UTSUN(DAYN,SALTS,I,*340) C UTROT is passed via /SPHERE/, HASUN via /CSUN/. IF(I.EQ.3)THEN UTBGN=UTROT STBGN=MOD(RASUN+HASUN+TWOPI,TWOPI) RABGN=MOD(RASUN+HASUN+TWOPI-DH,TWOPI) ELSE STEND=MOD(RASUN+HASUN+TWOPI,TWOPI) RAEND=MOD(RASUN+HASUN+TWOPI+DH,TWOPI) UTEND=UTROT END IF 340 CONTINUE C STBGN is LST at start (end of nautical twilight); etc. IF(DH.EQ.TWOPI)THEN STBGN=0. STEND=TWOPI END IF C DARKT=MOD(UTEND-UTBGN+1.,1.) C FEWER EXT.STARS NEEDED AT HIGH ELEVATIONS. NEEDEX=40.*DARKT*DRAT C ADD EXTRAS TO GET DEAD TIME. IF(NEEDED)NEEDEX=NEEDEX+4 NEEDS=MAX(NEEDST,NEEDEX) NEXCES=(NEEDS*3)/2 C C SELECT EXTINCTION STARS. C DELMAX=MIN(ALAT+ZDMIN,PI/2.) DELMIN=MAX(ALAT-ZDMIN,-PI/2.) C DELs limit stds.zone; DEXs limit ext.star zone. IF(JSYS.EQ.0)THEN C all ext.if no std.system. NEEDST=NEEDEX END IF C XS(1)=SIN(DELMAX) XS(2)=SIN(DELMIN) C=== IF(NEEDEX.GE.NEEDST)THEN DEXMAX=DELMAX DEXMIN=DELMIN ELSE C DUM is zone height needed. DUM=((XS(1)-XS(2))*NEEDEX)/NEEDST C sines first. DEXMAX=(SINPHI+DUM)/2. DEXMIN=(SINPHI-DUM)/2. C IF(DEXMAX.GT.XS(1))THEN DEXMAX=XS(1) DEXMIN=XS(1)-DUM ELSE IF(DEXMIN.LT.XS(2))THEN DEXMAX=XS(2)+DUM DEXMIN=XS(2) END IF C C back to angles. DEXMAX=ASIN(DEXMAX) DEXMIN=ASIN(DEXMIN) END IF C=== C C HERE AFTER FAINTS RESET. 342 NSET=0 NUMEXT=0 C DO 350 I=1,LASTD C C Tests for POSITION: C C increasing R.A. --> C C RA = RABGN STBGN STEND RAEND C | | | | C +- -------------------- -+ <-- DELMAX C : /: :\ : C :/ : : \: C West | + + | East <-- Delta = Phi C :\ : : /: C : \: :/ : C +- -------------------- -+ <-- DELMIN C C First, REJECT all OUTside "Bounding Box": C DEC limits violated... IF(DECS(I).GT.DELMAX .OR. DECS(I).LT.DELMIN .OR. C ...or V.E. outside box and RA limits violated... 1 (RABGN.LT.RAEND .AND. (RAS(I).LT.RABGN .OR. RAS(I).GT.RAEND)) C ...or V.E. inside box and RA limits violated. 2 .OR. (RAS(I).GT.RAEND .AND. RAS(I).LT.RABGN) ) GO TO 350 C (note that this guarantees RABGN.GT.RAEND.) C C Next, ACCEPT all INside "inscribed rectangle": C V.E. outside box and ST limits safe... IF ( (RAS(I).GT.STBGN .AND. RAS(I).LT.STEND) .OR. C or V.E. inside box and ST limits safe. 1 (STBGN.GT.STEND .AND. (RAS(I).LT.STEND .OR. RAS(I).GT.STBGN) ) 2 ) GO TO 343 C C We are now left with only the ends. C West end: C V.E. outside box and star between RABGN and STBGN... IF ( (RAS(I).GT.RABGN .AND. RAS(I).LT.STBGN) .OR. C or V.E. inside box and ST limits safe. 1 (RABGN.GT.STBGN .AND. (RAS(I).LT.STBGN .OR. RAS(I).GT.RABGN) ) 2 ) THEN C Check distance from Western pivot, at R.A.=STBGN, Dec.=Phi: COSANG=SIN(DECS(I))*SINPHI+COS(DECS(I))*COSPHI*COS(RAS(I)-STBGN) IF (COSANG.LT.COSMIN) GO TO 350 ELSE C East end: C Check distance from Eastern pivot, at R.A.=STEND, Dec.=Phi: COSANG=SIN(DECS(I))*SINPHI+COS(DECS(I))*COSPHI*COS(RAS(I)-STEND) IF (COSANG.LT.COSMIN) GO TO 350 END IF C Whatever falls through here is IN the semicircles at ends. C C Test for MAGNITUDES. 343 DO 345 NB=1,NBANDS AMAG=0. DO 344 K=1,NBANDS 344 AMAG=AMAG+COLORS(K,I)*COLRIN(K,NB) IF(AMAG.GT.FAINTS(NB) .OR. 1(.NOT.DC .AND. AMAG.LT.BRITES(NB)))GO TO 350 345 CONTINUE NSET=NSET+1 C Is subset full? IF(NSET.GT.MSET)THEN CALL EXCEED(NSET,'MSET',MSET) CALL TV('REDUCE ACCEPTABLE RANGE.') NSET=MSET GO TO 385 END IF C NO. File in list. XS(NSET)=RAS(I)*12./PI YS(NSET)=DECS(I)/DEGRAD DECLIM(1)=MIN(DECLIM(1),YS(NSET)) DECLIM(2)=MAX(DECLIM(2),YS(NSET)) C KTYPE =1 for STD., 2 for regular EXT., 3 for Special stars. KTYPE(NSET)=1 C NCAT is catalog number. NCAT(NSET)=I IF(DECS(I).LT.DEXMAX .AND. DECS(I).GT.DEXMIN)THEN NUMEXT=NUMEXT+1 KTYPE(NSET)=2 END IF C IF(.NOT.REDUCD .AND. NSET.GT.NEXCES)THEN C SHRINK ZONE IF TOO MANY STDS. SZMIN=(1.+3.*SZMIN)/4. REDUCD=.TRUE. GO TO 331 END IF 350 CONTINUE C IF(NSET.LT.2 .OR. JSYS.EQ.0)GOTO356 C GET COLOR RANGES. REDS(1)=COLORS(KY,NCAT(1)) BLUES(1)=COLORS(KY,NCAT(1)) REDS(2)=COLORS(KX,NCAT(1)) BLUES(2)=COLORS(KX,NCAT(1)) DO 351 NOBJ=2,NSET I=NCAT(NOBJ) REDS(1)=MAX(REDS(1),COLORS(KY,I)) BLUES(1)=MIN(BLUES(1),COLORS(KY,I)) REDS(2)=MAX(REDS(2),COLORS(KX,I)) 351 BLUES(2)=MIN(BLUES(2),COLORS(KX,I)) C TEST NON-EXTINCTION STDS. FOR EXTREME COLORS. DO 352 NOBJ=1,NSET I=NCAT(NOBJ) IF(COLORS(KY,I).EQ.REDS(1) .OR. COLORS(KX,I).EQ.REDS(2) .OR. 1 COLORS(KY,I).EQ.BLUES(1) .OR. COLORS(KX,I).EQ.BLUES(2))THEN C USE EXTREME-COLOR STAR FOR EXTINCTION. IF(KTYPE(NOBJ).EQ.1)NUMEXT=NUMEXT+1 KTYPE(NOBJ)=3 END IF 352 CONTINUE IF(NEEDED)THEN C$$$USE BRIGHTEST STARS TO IMPROVE DEAD TIME. (SET KTYPE=3) END IF C C ENOUGH EXT.STARS? C=== 356 IF(NUMEXT.LT.NEEDEX .OR. NSET.LT.NEEDST)THEN C NO. WIDEN ZONE. C -- IF(SZMIN.LT.1.25)THEN SZMIN=SZMIN+.05 WRITE(PAGE,'('' ONLY'',I3,'' STARS. Expand min.secz to'',F6.3)') 1 NSET,SZMIN CALL TV(PAGE(1)) GO TO 331 C -- ELSE C -- IF(NUMEXT.LT.NEEDEX)THEN WRITE(ASSUM4,358) NEEDEX,' EXTINCTION ',NUMEXT CALL TV(ASSUME(4)) CALL TV(ASSUME(5)) END IF IF(NSET.LT.NEEDST)THEN WRITE(ASSUM6,358) NEEDST,'TRANSFORMATION',NSET CALL TV(ASSUME(6)) CALL TV(ASSUME(7)) END IF 358 FORMAT('You need about ',I2,1X,A,' stars,'/7X,'but only ',I2, 1' are available.') C REVISE BRITES IF IT WILL HELP. IF(PC .AND. .NOT.(DC .OR. NEEDIM .OR. DIMMED))THEN NEEDIM=.TRUE. CALL BRITEN(BANDS,DIMMED) IF(DIMMED)GO TO 330 NEEDIM=.FALSE. END IF CALL TV(' You need more STD.stars.') CALL ASK('Give up?',A) IF(A.EQ.'Y' .OR. A.EQ.'O')THEN IF(CODEDS)CLOSE(K7,STATUS='DELETE') CLOSE(K9,STATUS='DELETE') CALL TV('Too few stds. -- ABANDONED') CALL STSEPI END IF C END IF C -- END IF C=== C WRITE(PAGE,359)SZMIN,NUMEXT,NSET 359 FORMAT(4X,'min.airmass =',F6.3,/I6,' Extinction stars,',I6, 1' Total standards.') CALL TVN(PAGE(1)) CALL TVN(PAGE(2)) CALL TVN(' ') CALL RTNCON(' ',1) C LIST STDS. IF(NSET.EQ.0) GO TO 387 C IF(CODEDS)THEN WRITE(K9,360)'STANDARD' 360 FORMAT(/4X,'CODE',2X,A8,' STARS'/) DO 370 NOBJ=1,NSET I=NCAT(NOBJ) C WRITE(K7,F361)NOBJ,STARS(I) CALL OUT361(K7,F361,NOBJ,STARS,I) 370 CALL OUT361(K9,F361,NOBJ,STARS,I) END IF C IF(NSET.LT.(3*NEEDST)/4)GO TO 387 C CALL PLOT(0,RALIMS,DECLIM,'L') CALL PLOT(0,79.,21.,'P') IF(NEEDH.GT.1)CALL TV('Standard Stars on sky -- $ = overlaps') CALL TV(DECLBL) CALL PLOT(NSET,XS,YS,'*') CALL RTNCON(RALBL,22) C Plot on PROUT. DUM=K9 CALL PLOT(0,DUM,DUM,'U') CALL PLOT(0,RALIMS,DECLIM,'L') C CALL PLOT(0,103.,(DECLIM(2)-DECLIM(1))/6.+6.,'P') CALL PLOT(0,79.,(DECLIM(2)-DECLIM(1))/6.+6.,'P') WRITE(K9,'(/1X,A)')DECLBL CALL PLOT(NSET,XS,YS,'*') WRITE(K9,'(A)')RALBL DUM=KTV CALL PLOT(0,DUM,DUM,'U') C IF(NBANDS.LE.2)GO TO 385 IF(NEEDH.GT.1) CALL TV( 1' X = EXTINCTION, S = STD.STAR $ = OVERLAP') WRITE(PAGE,381)CNAMES(1,KY)(:LENC),CNAMES(1,KX)(:LENC) 381 FORMAT(/4X,A,' vs. ',A,' two-color diagram') CALL TV(PAGE(2)) CALL PLOT(0,60.,23.,'P') CALL PLOT(0,XINV,YINV,'I') A='X' C MUST DO X FIRST TO SET LIMITS. DO 384 NTYPE=1,2 N=0 DO 382 NOBJ=1,NSET J=NCAT(NOBJ) IF(NTYPE.NE.2)THEN IF(KTYPE(NOBJ).LT.2) GO TO 382 ELSE IF(KTYPE(NOBJ).GE.2) GO TO 382 END IF N=N+1 XS(N)=COLORS(KX,J) YS(N)=COLORS(KY,J) 382 CONTINUE IF(N.NE.0) CALL PLOT(-N,XS,YS,A) 384 A='S' CALL PLOT(1,99.,99.,A) TITLE=' ('//CNAMES(1,KX)(:LENC)//')' CALL RTNCON(TITLE,LENC+14) C 385 WRITE(PAGE,359)SZMIN,NUMEXT,NSET CALL TVN(PAGE(1)) CALL TVN(PAGE(2)) IF(NSET.GT.NEXCES)THEN WRITE(PAGE,'(/'' only'',I3,'' Stds.needed.'')')NEEDS CALL TV(PAGE(2)) IF(NSET.GT.NEXCES+NEXCES)GO TO 387 END IF 386 CALL ASK('Are these stars OK?',A) IF(A.EQ.'Y' .OR. A.EQ.'O') GO TO 400 C C REVISE STAR LIST. C 387 IF(NEEDH.GT.0) THEN CALL TVN(' ') CALL TV( 1 '(Reply "NO" to the next question if you want no changes.)') END IF CALL ASK('Change Sky Area or Magnitude Limits?',A) C C=== IF(A.EQ.'S' .OR. A.EQ.'A')THEN C C SKY AREA. C -- IF(NSET.LT.NEEDST)THEN A='E' CALL TV('TOO FEW Stds., so expand.') ELSE IF(NSET.GT.NEXCES)THEN A='S' CALL TV('TOO MANY Stds.,so shrink.') ELSE CALL ASK('Shrink or Expand?',A) END IF C -- IF(A.EQ.'S')THEN SZMIN=(1.+2.*SZMIN)/3. ELSE IF(A.EQ.'E')THEN SZMIN=SZMIN+.05 ELSE GO TO 385 END IF C -- WRITE(PAGE,'(/'' Try min.airmass ='',F6.3/)')SZMIN CALL TV(PAGE(2)) IF(SZMIN.GE.1.2)CALL TV('CAUTION -- Should not exceed 1.25') CALL REHEAD(NDIG,DAT,CODEDS) IF(OLDEQ.NE.3.E33)WRITE(K9,328)DATEP GO TO 331 C = ELSE IF(A.EQ.'M' .OR. A.EQ.'L')THEN C = C MAG.LIMITS. C CALL MAGSET(BANDS) CALL REHEAD(NDIG,DAT,CODEDS) IF(OLDEQ.NE.3.E33)WRITE(K9,328)DATEP GO TO 342 C = ELSE IF(A.EQ.'N')THEN GO TO 386 C = ELSE IF(HELP(A))THEN CALL TV( 1'You can expand sky area or set fainter limits to get more stars.' 2) GO TO 387 C = ELSE GO TO 385 C = END IF C=== C 400 IF(NSTARS.EQ.LASTD)GO TO 405 C C ADD PROGRAM STARS. C IF(CODEDS)WRITE(K9,360)'PROGRAM' J=NSET OSTAR=' ' DO 402 I=LASTD+1,NSTARS IF(COLORS(MBANDS,I).GT.100. .AND. STARS(I).EQ.OSTAR) GO TO 402 C USE 1ST EPHEMERIS ENTRY. J=J+1 C IF(J.GT.MSET)THEN CALL EXCEED(J,'MSET',MSET) CALL STETER(401, 'NOT ENOUGH ROOM FOR PGM.STARS') END IF C IF(CODEDS .AND. STARS(I).NE.STARS(I-1))THEN C use 1st entry for ephemeris object. CALL OUT361(K7,F361,J,STARS,I) CALL OUT361(K9,F361,J,STARS,I) END IF C KTYPE(J)=0 NCAT(J)=I 402 OSTAR=STARS(I) NSET=J C 405 IF(NBANDS.LE.2)GO TO 410 C C plot 2-color diagram on printed o/p. C WRITE(K9,'(//18X,A)')'X = Extinction, S = Std.star, $ = overlap' WRITE(K9,381)CNAMES(1,KY)(:LENC),CNAMES(1,KX)(:LENC) DUM=K9 CALL PLOT(0,DUM,DUM,'U') CALL PLOT(0,60.,32.,'P') CALL PLOT(0,XINV,YINV,'I') A='X' C MUST DO X FIRST TO SET LIMITS. DO 407 NTYPE=1,2 N=0 DO 406 NOBJ=1,NSET J=NCAT(NOBJ) IF(NTYPE.NE.2)THEN IF(KTYPE(NOBJ).LT.2) GO TO 406 ELSE IF(KTYPE(NOBJ).GE.2) GO TO 406 END IF N=N+1 XS(N)=COLORS(KX,J) YS(N)=COLORS(KY,J) 406 CONTINUE IF(N.NE.0) CALL PLOT(-N,XS,YS,A) 407 A='S' CALL PLOT(1,99.,99.,A) TITLE=' ('//CNAMES(1,KX)(:LENC)//')' WRITE (K9,'(A)')TITLE C WRITE (K9,'(A)')FF C Generate "Special Instructions" page: WRITE(K9,'(10X,''S P E C I A L I N S T R U C T I O N S :'')') WRITE(K9,'(10X,''-----------------------------------------''//)') IF (FUNK) 1 WRITE(K9,'(10X,''FIND OUT if RED-LEAK filter is cemented''/)') IF (FCORN) 1 WRITE(K9,'(10X,''FIND OUT if RED-LEAK filter is Pyrex''/)') WRITE(K9,'(10X,''FIND OUT the ACTUAL condition of the optics:'')') WRITE(K9,'(54X,''.............''/)') C 410 CONTINUE C C SUMMARIZE FINAL CONDITIONS. C IF(NUMEXT.LT.NEEDEX)THEN NASSMP=NASSMP+2 ASSMPS(NASSMP-1)=ASSUME(4) ASSMPS(NASSMP)=ASSUME(5) END IF IF(NSET.LT.NEEDST)THEN NASSMP=NASSMP+2 ASSMPS(NASSMP-1)=ASSUME(6) ASSMPS(NASSMP)=ASSUME(7) END IF IF(SZMIN.GT.1.25)THEN NASSMP=NASSMP+1 ASSMPS(NASSMP)=ASSUME(8) END IF C IF(DC) TSUGG=TSUGG+TSUGG WRITE(K9,412)INT(TSUGG),SIGTOT 412 FORMAT(//' Use integrations of AT LEAST',I3,' SECONDS to get',F6.3 1,' mag.precision.'/) C WRITE(K9, 1 '(/'' BE SURE to fill in Temp. & R.H. data when you start a page. 2'')') C C C ***** BEGIN LOOP OVER NIGHTS. C DO 700 NIGHT=1,INT(DJS(2)-DJS(1)+1.5) C DJ=(NIGHT-1)+DJS(1) C assemble double date. CALL JD2DAT(DJ-1.,DAT) CALL JD2DAT(DJ,DMS) C same YEAR? IF(DMS(8:11).EQ.DAT(8:11))THEN C same MONTH? IF(DMS(:3).EQ.DAT(:3))THEN DAT(7:)='-'//DMS(5:11) C Different MONTHS. ELSE DAT(7:)='/'//DMS(:11) END IF C Different YEARS. ELSE DAT(12:)='/'//DMS END IF C PAGE(1)='Working on: '//DAT CALL TV(PAGE(1)) DAYN=DJ-2451545.0 T=DAYN/36525. CALL STUTZR(T) STZROT=STUTZ/TWOPI C C SUN & MOON AT MIDNIGHT. CALL SUN(DAYN-ELROT) C STORED SOLONG; MOON NEXT. CALL MOON(T-ELROT/36525.,0.) C DOT PROD. IS COS(PHASE). PHASE=ACOS(COS(ELMOON)*COS(BMOON)*COS(SOLONG+PI) + 1 SIN(ELMOON)*COS(BMOON)*SIN(SOLONG+PI)) C ROUGIER'S PHASE FCN.(P&S,P.289), IN RAD. DMAG=PHASE*(1.748+PHASE*(-.335+PHASE*.197)) NT=10 C IF(DMAG.LT.6.8)THEN C TWILIGHT LIMIT. SALTS(11)=.0154*DMAG-.12 SALTS(12)=SALTS(11) NT=12 END IF C IF(PHASE.GT.2.)GO TO 425 C AIR-MASS CHANGES .04/MIN.=9.17/RAD. N.B.:MOON IN SOLAR SLOTS. SIND=SIN(DESUN) COSD=COS(DESUN) C STARTING VALUE: ASSUME SIN H = 1. COSZ=SQRT(COSD*COSPHI/9.17) BAD=.FALSE. 420 DO 423 LOOP=1,9 ARG=COSD*COSD*COSPHI*COSPHI-(COSZ-SIND*SINPHI)**2 IF(ARG.LT.0.)THEN IF(BAD) GO TO 425 BAD=.TRUE. COSZ=0.09 GO TO 420 ELSE OLDCOS=COSZ COSZ=SQRT(SQRT(ARG)/9.17) IF(BAD)COSZ=(COSZ+OLDCOS)*.5 END IF IF(ABS(COSZ-OLDCOS).LT..001)GO TO 424 423 CONTINUE 424 NT=14 C ALT.IS COMP.OF Z. SALTS(13)=ASIN(COSZ) SALTS(14)=SALTS(13) C 425 UTBGN=0. UTEND=0. DO 430 I=1,NT TIMES(I)=3.E33 C IF(I.LE.8)THEN C SUN. CALL UTSUN(DAYN,SALTS,I,*430) IF(I.EQ.3)UTBGN=UTROT IF(I.EQ.6)UTEND=UTROT ELSE C MOON. CALL UTMOON(T,SALTS,I,*430) IF(UTROT.LT.UTBGN .OR. UTROT.GT.UTEND) GO TO 430 END IF C C STORE EVENTS IN LOG. TIMES(I)=UTROT C NEG.NOBJS FLAGS NONSTELLAR EVENT. NOBJS(I)=-I 430 CONTINUE C IF(UTEND.EQ.UTBGN)THEN CALL TV('TWILIGHT ALL NIGHT') CALL STETER(431, 'NO DARKNESS.') END IF DARKT=MOD(UTEND-UTBGN+1.,1.) C NEEDED BY FILL. C IF (DARK) THEN C DO N DARKS. N=72.*DARKT+2. DUM=DARKT/(N-1) I1=NT+1 NT=NT+N DO 432 I=I1,NT TIMES(I)=UTBGN+DUM*(I-I1) 432 NOBJS(I)=-15 END IF C C add reminder about cooling... IF(COOLED)THEN NT=NT+1 NOBJS(NT)=-16 TIMES(NT)=UTBGN-1./8. END IF C C LOOP OVER STARS. C DO 450 NOBJ=1,NSET I=NCAT(NOBJ) IF(COLORS(MBANDS,I).LT.100.)THEN C NORMAL STAR. RA=RAS(I) DEC=DECS(I) ELSE C EPHEMERIS OBJECT AT MIDNIGHT. CALL EPHEM(I,(DJ-2400000.)-ELROT,COLORS,RA,DEC) END IF C C SET UP FOR RISE/SET FIRST. COSZ=0.423 C FIND HA FOR SECZ=2.36 C DO 443 J=1,2 COSHA=(COSZ-SIN(DEC)*SINPHI)/(COSPHI*COS(DEC)) IF(ABS(COSHA).GT.1.0)GOTO445 HA=ACOS(COSHA) C USE TRANSIT ONLY, IF E/W ARE CLOSE. IF(HA.LT.0.1)GO TO 445 C EAST. CALL FILL(RA-HA,NOBJ,*442) C FINDS NT; STORES UTROT IN TIMES(NT) IF UT IS OK; C GOES TO 442 IF UT NOT IN (UTBGN,UTEND). IDS(NT)=ELABEL(J) C WEST. 442 CALL FILL(RA+HA,NOBJ,*443) IDS(NT)=WLABEL(J) C C SET FOR ZENITH STARS. 443 COSZ=COSMIN C IF(HA.GT.0.1)GO TO 450 C SKIP TRANSIT IF EAST/WEST ZENITH ALREADY. C C TRANSIT. 445 CALL FILL(RA,NOBJ,*450) IDS(NT)=' TRANSIT' 450 CONTINUE NTIMES=NT CALL SORTBL(NTIMES,TIMES,NOBJS,IDS) C C LIST FINAL RESULTS. C N=INDEX(PLACE,'Obs') IF (N.GT.0) PLACE(N:)=' ' N=LWORD(PLACE) IF(N.LE.12) WRITE(PLACE(N+1:),'(I5,''-cm'')') INT(TELCM) C UT2ST=1./ST2UT C lines/page: LPP=55 C page heading: WRITE(K9,640)FF,DAT,DJ,PLACE,TEMPRH,TL,(CNAMES(1,NB),NB=1,NBANDS) 640 FORMAT(A1/1X,A28,' Julian Date ',F10.1,3X,'at',2X,A20//17X,A34/ 1 23X,'......',8X,'......',8X,'..........'// 2 3X,A4,10X,'EVENT',27X,'R.A.',10X,'DEC.',7X,A6/' -------',3X, 3 '----------------------------',7X,'----------',4X,'----------', 4 3X,A6/(73X,1A6)) LINE=NBANDS+5 C C **** BEGIN output loop over stars **** C DO 670 I=1,NTIMES IF(TIMES(I).EQ.3.E33)GO TO 670 C Page Heading: C Zone time. IF(ITIME.EQ.2) TIMES(I)=TIMES(I)-ZONE C LST. IF(ITIME.EQ.3) TIMES(I)=TIMES(I)*UT2ST+STZROT+ELROT UTSTR=DEG2M1(MOD(TIMES(I)+2.,1.)*24.) C===== IF(NOBJS(I).GT.0) GOTO 660 IF(LINE.GT.LPP-3) THEN WRITE(K9,640)FF,DAT,DJ,PLACE,TEMPRH,TL, 1 (CNAMES(1,NB),NB=1,NBANDS) LINE=NBANDS+5 END IF C Do SUN & MOON. WRITE(K9,650) UTSTR,TWILIT(-NOBJS(I)) 650 FORMAT(3X,'h m'/A9,1X,A28/) C = LINE=LINE+3 GOTO 670 C = C Here for other objects. 660 J=NCAT(NOBJS(I)) IF(LINE.GT.LPP-(NBANDS+2)) THEN WRITE(K9,640)FF,DAT,DJ,PLACE,TEMPRH,TL, 1 (CNAMES(1,NB),NB=1,NBANDS) LINE=NBANDS+5 END IF C -- IF(COLORS(MBANDS,J).GT.100.)GOTO 663 C FIXED STAR. RASTR=DEG2MS(RAS(J)/DEGRAD/15.) DESTR=DEG2MS(DECS(J)/DEGRAD) GOTO 665 C Moving. 663 CALL EPHEM(J,(DJ-2400000.)+TIMES(I),COLORS,RA,DEC) RASTR=DEG2MS(MOD(RA/TWOPI+1.,1.)*24.) DESTR=DEG2MS(DEC/DEGRAD) C -- 665 CALL OUTP(UTSTR,STARS,I,J,IDS,NOBJS,RASTR,DESTR,COLORS,NBANDS) LINE=LINE+NBANDS+2 C===== 670 CONTINUE C C **** END output loop over stars **** C WRITE(K9,'(/17X,A34)')TEMPRH C C END LOOP OVER NIGHTS. C 700 CONTINUE C C C EPILOGUE: C CALL TVN(' ') IF(NASSMP.LE.NEEDH+2)THEN WRITE(K9,'(//'' END OF RUN.'')') CALL TV('Thanks for using PEPSYS3''s Planner.') END IF C CALL TV('DON''T FORGET to send (PROUT) to the printer.') CALL TVN(' ') C NOBJ=3+(NSET/NEEDST)+(NUMEXT/NEEDEX) IF(NASSMP.NE.0 .AND. NASSMP.LT.NOBJ)THEN CALL TV(' * * * C A U T I O N : * * *') CALL TVN(' ') WRITE(K9,'(///6X,''C A U T I O N :''/)') C WRITE(PAGE,'(A40,A39)')(ASSMPS(I),I=1,NASSMP) CALL TV(' ') DO 997 I=1,NASSMP 997 CALL TVN(ASSMPS(I)) WRITE(K9,'(1X,A40/)')(ASSMPS(I),I=1,NASSMP) CALL TVN(' ') ELSE IF(NASSMP.GE.NOBJ)THEN C NEW PAGE IF NEEDED. IF(LINE.GT.LPP-NASSMP*2-3)WRITE(K9,640) WRITE(K9,'(//)') CALL SXB(K9,ASSMPS,NASSMP) CALL SXB(KTV,ASSMPS,NASSMP) END IF C REWIND K9 CLOSE(K9,STATUS='KEEP') IF(CODEDS)CLOSE(K7,STATUS='KEEP') C CALL TV('NORMAL END of PLANNER') C Restore flags: CALL STECNT('PUT',JCONT,JLOG,JDISP) CALL STSEPI C return code = 0 if no argument. END SUBROUTINE OUT361(KUNIT,FMT,NOBJ,STARS,I) C IMPLICIT NONE C INTEGER KUNIT, NOBJ, I C CHARACTER FMT*13 ,STARS(I)*32 WRITE(KUNIT,FMT)NOBJ,STARS(I) RETURN END SUBROUTINE SORTBL(NTIMES,TIMES,NOBJS,IDS) C IMPLICIT NONE C REAL TIMES,DUM INTEGER NTIMES,NOBJS,I,M,J,JJ C DIMENSION TIMES(NTIMES),NOBJS(NTIMES) CHARACTER*8 IDS(NTIMES), STR8 C C SORT ENTRIES. C I=1 453 I=I+I IF(I.LE.NTIMES)GO TO 453 M=I-1 455 M=M/2 IF(M.EQ.0) RETURN DO 460 JJ=1,NTIMES-M DO 458 I=JJ,1,-M IF(TIMES(I+M).GE.TIMES(I)) GO TO 460 DUM=TIMES(I) TIMES(I)=TIMES(I+M) TIMES(I+M)=DUM J=NOBJS(I) NOBJS(I)=NOBJS(I+M) NOBJS(I+M)=J STR8=IDS(I) IDS(I)=IDS(I+M) IDS(I+M)=STR8 458 CONTINUE 460 CONTINUE GO TO 455 END SUBROUTINE OUTP(UTSTR,STARS,I,J,ID,NOBJ,RA,DE,COLORS,NBANDS) C IMPLICIT NONE INTEGER I, J, NOBJ, NBANDS, KB, KTV, K2, K3, K4, K7, K8, K9, LEN, 1 LOWER, KBR, K REAL COLORS C INCLUDE 'MID_REL_INCL:mstars.inc' INCLUDE 'MID_REL_INCL:mbands.inc' C PARAMETER (MBANDS=9,MSTARS=1650) DIMENSION NOBJ(I),COLORS(MBANDS,MSTARS) CHARACTER*32 STARS(J) CHARACTER*20 STAR1,STAR2,RA,DE CHARACTER*8 UTSTR,ID(I) CHARACTER COMENT(MSTARS)*32,SPTYPE(MSTARS)*12,EMAG(MSTARS)*16 COMMON /NOTES/COMENT,SPTYPE,EMAG COMMON /FILNOS/ KB, KTV, K2, K3, K4, K7, K8, K9 C C check name for >20 chars: DO 5 LEN=32,19,-1 IF(STARS(J)(LEN:LEN).NE.' ') GO TO 8 5 CONTINUE LEN=19 8 CONTINUE IF (LEN.LE.20)THEN STAR1=STARS(J) STAR2=' ' ELSE C split name to fit: LOWER=MAX(6,LEN-20) KBR=INDEX(STARS(J)(LOWER:21),'=') IF(KBR.EQ.0) THEN KBR=INDEX(STARS(J)(LOWER:23),' ') IF (KBR.EQ.0)THEN KBR=INDEX(STARS(J)(LOWER:22),' ') IF (KBR.EQ.0) THEN KBR=INDEX(STARS(J)(LEN-20:21),'=') IF(KBR.EQ.0) KBR=INDEX(STARS(J)(LEN-20:21),':') IF(KBR.EQ.0) KBR=INDEX(STARS(J)(LEN-20:21),',') IF(KBR.EQ.0) KBR=INDEX(STARS(J)(LEN-20:21),'.') IF(KBR.EQ.0) KBR=INDEX(STARS(J)(LEN-20:21),' ') KBR=KBR+LEN-21 ELSE KBR=KBR+LOWER-1 END IF ELSE KBR=KBR+LOWER-1 END IF ELSE KBR=KBR+LOWER-1 END IF STAR1=STARS(J)(:KBR-1) STAR2=STARS(J)(KBR:) END IF C WRITE(K9,666) UTSTR,STAR1,ID(I),NOBJ(I),RA,DE,COLORS(1,J), 1 STAR2, COLORS(2,J), 2 COMENT(J),EMAG(J),SPTYPE(J), (COLORS(K,J),K=3,NBANDS) 666 FORMAT(3X,'h m',34X,'No.',4X,'h m s o '' "'/ 1 A8,3X,A20,A8,I4,2(2X,A12),1X,F5.2/11X,A20,41X,F5.2/11X,A32,A16, 2 1X,A12,F5.2/(72X,F5.2)) IF (NBANDS.LT.3) WRITE(K9,'(1X)') RETURN END