C @(#)horform.for 17.1.1.1 (ES0-DMD) 01/25/02 17:17:32 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 PROGRAM HORFRM C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C.COPYRIGHT (c) C.IDENT horform.for C.MODULE C.AUTHOR Andrew T. Young C.KEYWORD C.LANGUAGE FORTRAN 77 C.PURPOSE generate horizon-table forms C.COMMENTS C.VERSION 0.0 C.RETURNS C.ENVIRONMENT requires esotel.tbl in local directory C. C----------------------------------------------------------------------------- C IMPLICIT REAL (A-H,O-Z) IMPLICIT INTEGER (I-N) C C BEGIN Declarations: C DOUBLE PRECISION DNULL COMMON /NULLS/ INULL, RNULL, DNULL C LOGICAL NULL INTEGER NOUT,NFILE CHARACTER*80 TOP,LINE2,LINE3,LINE4,LINE5,LINE6,GAP,FOOT CHARACTER*80 SPACER CHARACTER*84 FMT2,FMT3 CHARACTER*64 GERMAN(2) CHARACTER*8 TELNAMES(100),TELESCOP,FMT1, MOUNTING REAL PHIS(100),PHI,DELTA(0:50) C C Set up MIDAS declarations: C INTEGER MADRID(1) C COMMON /VMR/ MADRID C INCLUDE 'MID_INCLUDE:ST_DEF.INC' C C END Declarations. C C C BEGIN DATA statements: C INCLUDE 'MID_INCLUDE:ST_DAT.INC' C DATA FMT1/'(4X,A76)'/ DATA NFILE/7/ C C END DATA statements. C C C ******************** PROLOGUE ******************** C CALL STSPRO ('HORFRM') OPEN(NFILE,FILE='FORM',STATUS='UNKNOWN') REWIND NFILE C C Real program begins here: (use RUN HORFORM to test in MIDAS) C CALL TBTOPN('esotel.tbl',0,ITBL,ISTAT) IF (ISTAT.NE.0) THEN CALL STTPUT('esotel.tbl not found',NOUT) CALL STETER(1, 'Error while opening esotel.tbl') END IF C TBLSER search for table column with given label; get number CALL TBLSER (ITBL, 'TELESCOP', NCTEL, ISTAT) IF (ISTAT.NE.0) THEN CALL STTPUT('Failed to find TELESCOP column',NOUT) CALL STETER(2, 'Error while reading esotel.tbl') END IF CALL TBLSER (ITBL, 'LAT', NCLAT, ISTAT) IF (ISTAT.NE.0) THEN CALL STTPUT('Failed to find LAT column',NOUT) CALL STETER(3, 'Error while reading esotel.tbl') END IF C C find number of rows: CALL TBIGET(ITBL, NCOLS, NROWS, NSORTC, NWPRAL, NROWSAL, ISTAT) C loop over rows: DO 5 NROW=1,NROWS C read telnames(nrow): CALL TBERDC(ITBL,NROW,NCTEL,TELNAMES(NROW),NULL,ISTAT) C read phis(nrow)=LAT: CALL TBERDR(ITBL,NROW,NCLAT,PHIS(NROW),NULL,ISTAT) 5 CONTINUE C C display menu: C 6 CALL MENU1('Please choose a telescope:',TELNAMES,NROWS,NOUT) C STKPRC prompt user for character-valued keyword data at terminal CALL STKPRC ('Please enter your selection:','INPUTC', 1, 1, 8, 1 NACTEL, TELESCOP, IUNIT, NULLS, ISTAT) C convert to caps: IDIFF=ICHAR('A')-ICHAR('a') DO 8 I=1,8 IF(ICHAR(TELESCOP(I:I)).GE.ICHAR('a')) 1 TELESCOP(I:I)=CHAR(ICHAR(TELESCOP(I:I))+IDIFF) 8 CONTINUE DO 10 NROW=1,NROWS IF (TELNAMES(NROW) .EQ. TELESCOP) GOTO 20 10 CONTINUE C no match, so assume number was entered: READ(TELESCOP,'(I3)',ERR=6) NROW IF (NROW.GT.NROWS) GO TO 6 TELESCOP=TELNAMES(NROW) 20 PHI=PHIS(NROW) C C Begin converted awk script: C DEGRAD=180./3.1415926535 ABSPHI=ABS(PHI) COSPHI=COS(PHI/DEGRAD) MOUNTING=' ' 25 CALL STKPRC ('Is its mounting FORK, GERMAN, or ALTAZ?', 1 'INPUTC', 1, 1, 6, 2 NACTEL, MOUNTING, IUNIT, NULLS, ISTAT) C convert to caps: IDIFF=ICHAR('A')-ICHAR('a') DO 28 I=1,6 IF(ICHAR(MOUNTING(I:I)).GE.ICHAR('a')) 1 MOUNTING(I:I)=CHAR(ICHAR(MOUNTING(I:I))+IDIFF) 28 CONTINUE IF (MOUNTING.EQ.'FORK') THEN TOP(1:) = ' '// + '__________________________________________________' LINE2(1:) = ' |'// + ' | Looking EAST | Looking WEST |' LINE3(1:) = ' |'// + ' |===================|===================|' LINE4(1:) = ' |'// + ' | ALL | LAST | ALL | LAST |' LINE5(1:) = ' |'// + ' DEC. | CLEAR | SKY | CLEAR | SKY |' LINE6(1:) = ' |'// + ' | (OBSE) | (MOONE) | (OBSW) | (MOONW) |' SPACER(1:) = ' |'// + '--------+---------+---------+---------+---------|' GAP(1:) = ' |'// + ' | | | | |' FOOT(1:) = ' '// + '==================================================' FMT2(1:) = '('' | '', + F4.0,'' | | | | |'')' FMT3 = FMT2 FMT3(65:68)= 'omit' FMT3(45:48)= 'omit' GERMAN(1) = ' ' LOOPS = 1 C ELSE IF (MOUNTING.EQ.'GERMAN') THEN TOP(1:) = ' '// + '__________________________________________________' LINE2(1:) = ' |'// + ' | Looking EAST | Looking WEST |' LINE3(1:) = ' |'// + ' |===================|===================|' LINE4(1:) = ' |'// + ' | ALL | LAST | ALL | LAST |' LINE5(1:) = ' |'// + ' DEC. | CLEAR | SKY | CLEAR | SKY |' LINE6(1:) = ' |'// + ' | (TEOBSE)|(TEMOONE)| (TEOBSW)|(TEMOONW)|' SPACER(1:) = ' |'// + '--------+---------+---------+---------+---------|' GAP(1:) = ' |'// + ' | | | | |' FOOT(1:) = ' '// + '==================================================' FMT2(1:) = '('' | '', + F4.0,'' | | | | |'')' FMT3 = FMT2 FMT3(65:68)= 'omit' FMT3(45:48)= 'omit' GERMAN(1)=' T e l e s c o p e E A S T o f p i e r' GERMAN(2)=' T e l e s c o p e W E S T o f p i e r' LOOPS=2 C ELSE IF (MOUNTING.EQ.'ALTAZ') THEN TOP(1:) = ' '// + ' _____________________________________________' LINE4(1:) = ' '// + '| | ALL | LAST |' LINE5(1:) = ' '// + '| AZIMUTH | CLEAR | SKY |' LINE6(1:) = ' '// + '| (AZI) | (OBSALT) | (MOONALT) |' SPACER(1:)= ' '// + '|-------------+--------------+--------------|' GAP(1:) = ' '// + '| | | |' FOOT(1:) = ' '// + '==============================================' DO 36, J=0,35 IF (MOD(J,12).EQ.0 ) THEN IF (J.GT.0) THEN ! BREAK PAGE WRITE(NFILE,FMT1)FOOT WRITE(NFILE,'(1H1)') END IF WRITE(NFILE,'(A57,A8)') 1 ' L I M I T I N G A L T I T U D E S f o r ',TELESCOP WRITE(NFILE,FMT1) WRITE(NFILE,FMT1)TOP WRITE(NFILE,FMT1)GAP WRITE(NFILE,FMT1)LINE4 WRITE(NFILE,FMT1)LINE5 WRITE(NFILE,FMT1)GAP WRITE(NFILE,FMT1)LINE6 END IF WRITE(NFILE,FMT1)SPACER WRITE(NFILE,FMT1)GAP WRITE(NFILE,'('' | '',I3, + '' | | |'')')J*10 WRITE(NFILE,FMT1)GAP 36 CONTINUE WRITE(NFILE,FMT1)FOOT I=0 CALL STTPUT('Done!',NOUT) CALL STTPUT(' ',NOUT) CALL STTPUT(' --> Don''t forget to print the file FORM', 1 NOUT) CALL STTPUT(' ',NOUT) CALL STSEPI ELSE CALL STTPUT('Please reply FORK or GERMAN or ALTAZ only.' 1 ,NOUT) I=0 GOTO 25 END IF DELTA(0)=0. DCRIT=0. DO 50 I=1,49 DEL=DELTA((I-1))/DEGRAD ! RADIANS COSDEL=COS(DEL) RAT=SIN(DEL) / COSPHI IF (RAT.GE.1) THEN ! LAST ONE WAS CIRCUMPOLAR C last deg.of dec. that meets horizon: IF (DELTA((I-2)) .NE. 89-INT(ABSPHI) ) THEN DELTA(I-1)= 89-INT(ABSPHI) ELSE DELTA(I-1)= 90-INT(ABSPHI) END IF DO 45 J=I,I+5 DELTA(J)=DELTA((J-1))+1 45 CONTINUE K=I+5 GOTO 100 END IF C place intersections with horizon no more than 0.2 rad apart: DD=0.2*(COSPHI/COSDEL)*SQRT(1.-RAT*RAT) IF (DD .LT. 1./DEGRAD) DD=1.005/DEGRAD DELTA(I)=DELTA((I-1))+INT(DD*DEGRAD) C Moon only reaches 30 deg... IF (DCRIT.EQ.0. .AND. DELTA(I).GT.30.) DCRIT=DELTA(I) 50 CONTINUE K=49 C 100 LINE=3 I=K IF (I.EQ.0) CALL STSEPI I=I-1 DO 150 LOOP=1,LOOPS LINE=0 DO 110 J=I,0,-1 IF (MOD(LINE,10) .EQ.0) THEN IF (LINE.GT.0) THEN ! BREAK PAGE WRITE(NFILE,FMT1)FOOT WRITE(NFILE,'(1H1)') END IF WRITE(NFILE,'(A58,A8)') 1 ' H O U R A N G L E L I M I T S f o r ', 2 TELESCOP WRITE(NFILE,FMT1) IF (MOUNTING.EQ.'GERMAN') 1 WRITE(NFILE,FMT1)GERMAN(LOOP) WRITE(NFILE,FMT1) WRITE(NFILE,FMT1)TOP WRITE(NFILE,FMT1)LINE2 WRITE(NFILE,FMT1)LINE3 WRITE(NFILE,FMT1)LINE4 WRITE(NFILE,FMT1)LINE5 WRITE(NFILE,FMT1)GAP WRITE(NFILE,FMT1)LINE6 END IF LINE=LINE+1 WRITE(NFILE,FMT1)SPACER WRITE(NFILE,FMT1)GAP IF (DELTA(J).LE.DCRIT) THEN WRITE(NFILE, FMT2) DELTA(J) ELSE WRITE(NFILE, FMT3) DELTA(J) END IF WRITE(NFILE,FMT1)GAP 110 CONTINUE DO 120 J=1,I IF (MOD(LINE,10) .EQ.0) THEN IF (LINE.GT.0) THEN ! BREAK PAGE WRITE(NFILE,FMT1)FOOT WRITE(NFILE,'(1H1)') END IF WRITE(NFILE,'(A58,A8)') 1 ' H O U R A N G L E L I M I T S f o r ', 2 TELESCOP WRITE(NFILE,FMT1) IF (MOUNTING.EQ.'GERMAN') 1 WRITE(NFILE,FMT1)GERMAN(LOOP) WRITE(NFILE,FMT1) WRITE(NFILE,FMT1)TOP WRITE(NFILE,FMT1)LINE2 WRITE(NFILE,FMT1)LINE3 WRITE(NFILE,FMT1)LINE4 WRITE(NFILE,FMT1)LINE5 WRITE(NFILE,FMT1)GAP WRITE(NFILE,FMT1)LINE6 END IF LINE=LINE+1 WRITE(NFILE,FMT1)SPACER WRITE(NFILE,FMT1)GAP IF (DELTA(J).LE.DCRIT) THEN WRITE(NFILE, FMT2) -DELTA(J) ELSE WRITE(NFILE, FMT3) -DELTA(J) END IF WRITE(NFILE,FMT1)GAP 120 CONTINUE WRITE(NFILE,FMT1)FOOT IF (LOOPS.EQ.2) THEN LINE6= 1' | | (TWOBSE) | (TWMOONE) | (TWOBSW) | (TWMOONW) |' IF (LOOP.EQ.1) WRITE(NFILE,'(1H1)') END IF 150 CONTINUE CLOSE(NFILE) C CALL STTPUT('Done!',NOUT) CALL STTPUT(' ',NOUT) CALL STTPUT('--> Don''t forget to print the file FORM',NOUT) CALL STTPUT(' ',NOUT) C C End MIDAS: C CALL STSEPI C C C END SUBROUTINE MENU1(PROMPT,WORDS,NITEMS,NOUT) C IMPLICIT REAL (A-H,O-Z) IMPLICIT INTEGER (I-N) C CHARACTER*(*) PROMPT,WORDS(NITEMS) CHARACTER*80 CARD CHARACTER B24(2)*24, B16(4)*16, B8(8)*8, B64*64 EQUIVALENCE (B64,B24(1),B16(1),B8(1)) C C ***** Begin ***** C CALL STTPUT(PROMPT,NOUT) IF (NITEMS.LT.9)THEN DO 10 I=1,NITEMS B64=WORDS(I) WRITE(CARD,5) I,B64 5 FORMAT(20X,I2,':',2X,A50) CALL STTPUT(' ',NOUT) CALL STTPUT(CARD,NOUT) 10 CONTINUE ELSE IF (NITEMS.LT.17) THEN INC=NITEMS/2 DO 20 I=1,(NITEMS+1)/2 K=1 DO 12 J=I,NITEMS,INC B24(K)=WORDS(J) 12 K=K+1 WRITE(CARD,15) (I+(KK-1)*INC,B24(KK),KK=1,K) 15 FORMAT(10X,I2,':',2X,A24,8X,I2,':',A24) CALL STTPUT(' ',NOUT) CALL STTPUT(CARD,NOUT) 20 CONTINUE ELSE IF (NITEMS.LT.65) THEN INC=NITEMS/4 DO 30 I=1,(NITEMS+3)/4 K=1 DO 22 J=I,NITEMS,INC B16(K)=WORDS(J) 22 K=K+1 WRITE(CARD,25) (B16(KK),KK=1,K) 25 FORMAT(6X,4(2X,A16)) IF (NITEMS.LT.33) CALL STTPUT(' ',NOUT) CALL STTPUT(CARD,NOUT) 30 CONTINUE ELSE INC=NITEMS/8 DO 40 I=1,(NITEMS+7)/8 K=1 DO 32 J=I,NITEMS,INC B8(K)=WORDS(J) 32 K=K+1 WRITE(CARD,35) (B8(KK),KK=1,K) 35 FORMAT(4X,8(1X,A8)) CALL STTPUT(CARD,NOUT) 40 CONTINUE END IF CALL STTPUT(' ',NOUT) RETURN END