c c **** c ** PRECESSION AND AIRMASS PROGRAM c **** c c The basis of this program is to compute airmass for a c range of local observing times. This version created by J.A. c Cardelli & modified by Pat Hall. It gives you a MENU choice c of observatories including KPNO and CTIO. The program only c requires a choice of OBSERVATORY (you could also choose to c enter your own site), LOCAL observing DATE, and input DATA c on the objects of interest. You can read from a standard c file or create one as you go. All necessary information c such as TIME ZONE, SIDEREAL TIME, etc. is internally c computed. The program currently is set to calculate c sidereal times for the period 1981-2000. See the source c code K1 constants for more details on other dates. c STANDARD TIME has been set to run all year (AZ style). c **** c c c c c c **** c *** OBSERVATORIES * c **** c Observatory Latitude Longitude c 1: KPNO +31 57 48 +111 36 00 c 2: CTIO -30 09 55 +70 48 52 c 3: MMT +31 41 20 +110 53 04 c 4: Mt. Lemmon +32 12 48 +111 00 18 c 5: From Terminal o ' " o ' " c 6: Exit c **** c **** c c c c c c c c c c c program obsprepnew character signn(200)*1, newsignn(200)*1 character answer*3, timez*3, stimez(15)*3, dtimez(15)*3 character label*4 integer obsm, obsd, obsy, choice, m(12), days, dys real lt(13), k1, k2, k3 character sname(200)*9 c character data1(200)*12, data2(200)*12 character data1(200)*21, data2(200)*21 character line(70)*80 dimension x(200, 13), ira1(200), ira2(200), ra3(200), id1(200) &, epold(200), rahr(200), ra0(200), ddg(200), d0(200), t(200) &, zet0(200), z(200), th(200), rzet0(200), rz(200), rth(200), raz( &200), a(200), q(200), dam(200), fm(200), da(200), c(200), b(200), &tt(200), dd(200), d(200), ra(200), ra1(200), d1(200), jra1(200), &r2(200), jra2(200), r3(200), jd(200), dj2(200), hahr(200), ha(200) &, y(200), id2(200), id3(200) # 64 "obsprepnew.f" aflag = 0 iflag = 0 sflag = 0 c RUNNING NUMBER OF DAYS IN THE YEAR (BY MONTH) # 69 "obsprepnew.f" dflag = 0 m(1) = 0 m(2) = 31 m(3) = 59 m(4) = 90 m(5) = 120 m(6) = 151 m(7) = 181 m(8) = 212 m(9) = 243 m(10) = 273 m(11) = 304 # 82 "obsprepnew.f" m(12) = 334 c K1 CONSTANTS FOR 1990 - 2000 y(90) = 6.62651304 y(91) = 6.61061698 y(92) = 6.59470289 y(93) = 6.64449862 y(94) = 6.62858453 c discrepancies are a constant 2 minutes c y(95) = 6.61267044 y(95) = 6.64552541 c y(96) = 6.59675636 y(96) = 6.62961130 c y(97) = 6.64655209 y(97) = 6.67940702 c y(98) = 6.63063800 y(98) = 6.66349292 c y(99) = 6.61472391 y(99) = 6.64757882 # 101 "obsprepnew.f" c y(100) = 6.59880982 y(100) = 6.63166473 y(101) = 6.68146047 c c The K1 constants correspond to GMST at 0h UT on Jan. 0 c The formula for GMST on day d at t hours UT is c GMST = K1 + K2*d + K3*t (units of hours) c K1 = 24110.54841 + 8640184.812866*Tu + 0.093104*Tu^2 c - (6.2E-6)*Tu^3 (all constants carry time units of seconds) c or K1 = 6.6973745583333 + 2400.0513369072*Tu + (2.58622E-5)*Tu^2 c - (1.7E-9)*Tu^3 (all constants carry time units of hours) c where Tu = (JD-2451545.0)/36525 c Tu is the time interval, measured in Julian centuries of 36525 c days of universal time (mean solar days), elapsed since c epoch 2000 Jan. 1d 12h UT c # 118 "obsprepnew.f" c THE REMAINING CONSTANTS (K2 AND K3) k2 = 0.0657098232 k3 = 1.0027379093 c STANDARD AND DAYLIGHT SAVINGS TIME LABELS stimez(8) = 'PST' stimez(7) = 'MST' stimez(6) = 'CST' stimez(5) = 'EST' stimez(4) = 'AST' dtimez(8) = 'PDT' dtimez(7) = 'MDT' dtimez(6) = 'CDT' dtimez(5) = 'EDT' c c INITIALIZE AND PRINT MENU c # 135 "obsprepnew.f" dtimez(4) = 'ADT' # 137 "obsprepnew.f" 499 open(unit=1 *F77CVT -- VMS feature: TYPE= specifier in OPEN &, status='OLD' *F77CVT -- VMS feature: NAME= specifier in OPEN &, file='obsprepnew.f') # 143 "obsprepnew.f" read(unit=1, fmt=500, end=1000) (line(i),i = 1, 70) 500 format(6x,a80) close(unit=1) # 147 "obsprepnew.f" pi = 3.14159 # 149 "obsprepnew.f" 55 format(i1) 310 write(unit=*, fmt=501) (line(i),i = 24, 36) *F77CVT -- VMS feature: TYPE statement # 153 "obsprepnew.f" 311 write(unit=*, fmt=312) 312 format(/4x,22hWhich would you like? $) 501 format(4x,a65) read(unit=*, fmt=55, err=311, end=311) choice if (choice .eq. 1) then flatdg = 31.96333 flondg = 111.60000 label = 'KPNO' else if (choice .eq. 2) then flatdg = -30.16528 flondg = 70.81444 label = 'CTIO' else if (choice .eq. 3) then flatdg = 31.68878 flondg = 110.88456 label = 'MMT ' else if (choice .eq. 4) then flatdg = 32.21333 flondg = 111.00500 label = 'Mt.L' else if (choice .eq. 5) then iflag = 1 label = ' ' goto 150 else if (choice .eq. 6) then goto 1000 else goto 310 end if c c FLONHR AND FLATDG ARE THE LONGITUDE AND LATITUDE OF THE c OBSERVATORY BEING USED c THIS SECTION TO BE USED ONLY IF THE OBSERVING SITE c DOES NOT EXIST IN THE LIST GIVEN IN THE PROGRAM c # 175 "obsprepnew.f" if (iflag .eq. 0) goto 56 *F77CVT -- VMS feature: TYPE statement # 183 "obsprepnew.f" 150 write(unit=*, fmt=151) 151 format(/,x,33hLatitude (in DEGREES; Dg Mn Sc): $) read(unit=*, fmt=*, err=150, end=1000) flatd, flatm, flats *F77CVT -- VMS feature: TYPE statement # 187 "obsprepnew.f" 152 write(unit=*, fmt=153) 153 format(/,x,34hLongitude (in DEGREES; Dg Mn Sc): $) read(unit=*, fmt=*, err=152, end=1000) flond, flonm, flons # 191 "obsprepnew.f" flatdg = (flatd + (flatm / 60.)) + (flats / 3600.) c c # 192 "obsprepnew.f" flondg = (flond + (flonm / 60.)) + (flons / 3600.) # 195 "obsprepnew.f" 56 continue 156 format(i2) flonhr = flondg * (24. / 360.) ilon = int(flonhr) flat = (flatdg * pi) / 180. c c ENTER DATE c *F77CVT -- VMS feature: TYPE statement # 201 "obsprepnew.f" 154 write(unit=*, fmt=155) 155 format(/4x, &57hEnter LOCAL DATE at the start of observing (Mo Da Year): $) read(unit=*, fmt=*, err=154, end=164) obsm, obsd, obsy c added to account Y indexing for year >= 2000 # 206 "obsprepnew.f" obsy = obsy - 1900 # 208 "obsprepnew.f" days = m(obsm) + obsd yy = float(obsy) / 4. yyy = yy - int(yy) c GMST at 0h UT on Jan. 0 # 211 "obsprepnew.f" if ((yyy .eq. 0) .and. (obsm .ge. 3)) days = days + 1 c k1 = y(obsy) # 217 "obsprepnew.f" if (choice .ne. 2) then sflag = 1 dflag = 0 else if ((choice .eq. 2) .and. ((days .ge. 120) .and. (days .le. &302))) then # 221 "obsprepnew.f" sflag = 1 dflag = 0 else if (choice .eq. 2) then sflag = 0 dflag = 1 end if c # 233 "obsprepnew.f" epnew = (1900. + float(obsy)) + (float(days) / 365.) # 237 "obsprepnew.f" tz = abs(flonhr - float(ilon)) if (tz .gt. 0.5) then utd = float(ilon) + 1. else utd = float(ilon) end if # 244 "obsprepnew.f" if (choice .eq. 2) utd = utd - 1 # 246 "obsprepnew.f" if (sflag .eq. 1) then timez = stimez( *F77CVT -- VMS feature: non-integer subscript &int(utd)) # 248 "obsprepnew.f" else timez = dtimez( *F77CVT -- VMS feature: non-integer subscript &int(utd)) # 250 "obsprepnew.f" end if # 253 "obsprepnew.f" 164 continue c c ENTER COORDS FROM THE TERMINAL c *F77CVT -- VMS feature: TYPE statement # 255 "obsprepnew.f" 350 write(unit=*, fmt=351) 351 format(/4x, &45hDo you want to enter data from the TERMINAL? $) c IF(ANSWER.EQ.'N '.OR.ANSWER.EQ.'NO ') GO TO 360 # 258 "obsprepnew.f" read(unit=*, fmt=20, err=350, end=360) answer # 260 "obsprepnew.f" call yesno(answer, yn) if (yn .eq. 0) goto 360 # 263 "obsprepnew.f" n = 0 i = 1 # 267 "obsprepnew.f" write(unit=*, fmt=353) 353 format(/4x, &54hEntering data from the TERMINAL; Type to quit) c &54hEntering data from the TERMINAL; Type to quit) *F77CVT -- VMS feature: TYPE statement # 273 "obsprepnew.f" 361 write(unit=*, fmt=362) 362 format(//4x,26hStar Name (9 characters): $) read(unit=*, fmt=363, err=361, end=371) sname(i) 363 format(a9) *F77CVT -- VMS feature: TYPE statement # 277 "obsprepnew.f" 364 write(unit=*, fmt=365) 365 format(/4x,27hComment#1 (11 characters): $) read(unit=*, fmt=366, err=364, end=367) data1(i) 366 format(a12) *F77CVT -- VMS feature: TYPE statement # 281 "obsprepnew.f" 367 write(unit=*, fmt=368) 368 format(/4x,27hComment#2 (11 characters): $) read(unit=*, fmt=366, err=367, end=369) data2(i) *F77CVT -- VMS feature: TYPE statement # 287 "obsprepnew.f" 369 write(unit=*, fmt=355) 355 format(/4x,19hRA: (Hr Mn Sc.X)? $) read(unit=*, fmt=*, err=369) ira1(i), ira2(i), ra3(i) *F77CVT -- VMS feature: TYPE statement # 290 "obsprepnew.f" 375 write(unit=*, fmt=356) 356 format(4x,20hDec: (+/-Dg Mn Ss)? $) read(unit=*, fmt=376, err=375) signn(i), id1(i), id2(i), id3(i) newsignn(i) = signn(i) 376 format(a1,i2,i2,i2) *F77CVT -- VMS feature: TYPE statement # 295 "obsprepnew.f" 357 write(unit=*, fmt=358) 358 format(4x,19hEpoch: (Year.X)? $) c READ(*,*,ERR=357,END=371)IRA1(I),IRA2(I), c /RA3(I),SIGNN(I),ID1(I),D2(I),EPOLD(I) c WRITE(*,102)SNAME(I),IRA1(I),IRA2(I),RA3(I),SIGNN(I),ID1(I), c /D2(I),EPOLD(I),DATA1(I),DATA2(I) # 297 "obsprepnew.f" read(unit=*, fmt=*, err=357) epold(i) # 305 "obsprepnew.f" n = n + 1 i = i + 1 goto 361 *F77CVT -- VMS feature: TYPE statement # 308 "obsprepnew.f" 371 write(unit=*, fmt=372) 372 format(/4x, &51hDo you want to make a file with these coordinates? $) c IF(ANSWER.EQ.'N '.OR.ANSWER.EQ.'NO ') THEN # 311 "obsprepnew.f" read(unit=*, fmt=20, err=371, end=181) answer # 313 "obsprepnew.f" call yesno(answer, yn) if (yn .eq. 0) then goto 181 else write(unit=*, fmt=333) call wopen(2, 'Output file (re-usable "PRECESS" file)') do 373 i = 1, n write(unit=2, fmt=102) sname(i), ira1(i), ira2(i), ra3(i), signn(i &), id1(i), id2(i), id3(i), epold(i), data1(i), data2(i) 373 continue close(unit=2) goto 181 end if # 328 "obsprepnew.f" 360 continue n = 0 i = 1 c c ENTER COORDS FROM A FILE c c write(unit=*, fmt=380) c 380 format(/4x, c &48hEntering data from a FILE(S) ****) *F77CVT -- VMS feature: TYPE statement # 338 "obsprepnew.f" c 410 write(unit=*, fmt=411) c 411 format(/4x, c &58hDo you want to enter separate PROGRAM and STANDARD files? $) cc IF(ANSWER.EQ.'N '.OR.ANSWER.EQ.'N0 ') THEN c# 341 "obsprepnew.f" c read(unit=*, fmt=20, err=410, end=415) answer c# 343 "obsprepnew.f" c call yesno(answer, yn) c if (yn .eq. 0) then aflag = 0 c else c aflag = 1 c end if # 350 "obsprepnew.f" 415 write(unit=*, fmt=334) 334 format(/) # 353 "obsprepnew.f" call ropen(1, 'Input file (PROGRAM OBJECTS)') 1 read(unit=1, fmt=102, err=1000, end=162) sname(i), ira1(i), ira2(i &), ra3(i), signn(i), id1(i), id2(i), id3(i), epold(i), data1(i), d &ata2(i) # 357 "obsprepnew.f" newsignn(i) = signn(i) c c INPUT FORMAT c c input format: "star_name hh mm ss.s +hh mm ss 1950.0 comment1 comment2" c 102 format(a9,x,i2,x,i2,x,f4.1,x,a1,i2,x,i2,x,i2,x,f6.1,x,a12,a12) 102 format(a9,x,i2,x,i2,x,f4.1,x,a1,i2,x,i2,x,i2,x,f6.1,x,a21,a21) c 102 format(a9,i2,i2,f4.1,a1,i2,f4.1,f6.1,a12,a12) c 102 format(x,a9,i2,i2,f4.1,a1,i2,1x,f4.1,f6.1,x,a12,a12) c original format on next line: c x,a9,2i2,f4.1,a1,i2,1x,f4.1,f6.1,x,a12,a12 n = n + 1 i = i + 1 goto 1 162 close(unit=1) if (aflag .eq. 0) goto 181 write(unit=*, fmt=333) 333 format(/) call ropen(1, 'Input file (STANDARD STARS)') 2 read(unit=1, fmt=102, err=1000, end=180) sname(i), ira1(i), ira2(i &), ra3(i), signn(i), id1(i), id2(i), id3(i), epold(i), data1(i), d &ata2(i) # 370 "obsprepnew.f" newsignn(i) = signn(i) n = n + 1 i = i + 1 goto 2 180 close(unit=1) c c **** c THE FOLLOWING SECTION PRINTS A SCREEN FORMATTED DATA FILE THAT c CONTAINS THE INPUT DATA AND THE PRECESSED COORDINATES ONLY. c FOR NOW, THIS SECTION IS CLUMSILY LOCATED HERE INSTEAD OF AFTER c THE SECTION THAT CALCULATES THE PRECESSION CORRECTIONS. c **** c # 375 "obsprepnew.f" goto 181 # 384 "obsprepnew.f" 299 write(unit=*, fmt=277) 277 format(//,x, &70hInput Data: Star Name RA Dec Epoch C &omments,/) c IF(ID1(I).LT.0)THEN c D2(I)=-D2(I) c ELSE c ENDIF # 387 "obsprepnew.f" do 99 i = 1, n # 392 "obsprepnew.f" write(unit=*, fmt=278) sname(i), ira1(i), ira2(i), ra3(i), signn(i &), id1(i), id2(i), id3(i), epold(i), data1(i) 278 format(16x,a9,2x,i2,x,i2,x,f4.1,3x,a1,i2,x,i2,x,i2,2x,f6.1,5x,a12) # 397 "obsprepnew.f" write(unit=*, fmt=279) jra1(i), jra2(i), r3(i), newsignn(i), jd(i) &, dj2(i), data2(i) 279 format(19x,7hNEW: ,2i3,f5.1,3x,a1,i2,f5.1,13x,a12/) 99 continue *F77CVT -- VMS feature: TYPE statement # 401 "obsprepnew.f" 303 write(unit=*, fmt=304) 304 format(//,x,48hWould you like to write a PRINTER FILE of this? $) read(unit=*, fmt=20, err=303, end=1000) answer 20 format(a3) c IF (ANSWER.EQ.'NO '.OR.ANSWER.EQ.'N ')GO TO 305 # 405 "obsprepnew.f" write(unit=*, fmt=333) # 407 "obsprepnew.f" call yesno(answer, yn) if (yn .eq. 0) goto 305 call wopen(2, 'Screen formatted PRINTER file') write(unit=2, fmt=277) do 199 i = 1, n write(unit=2, fmt=278) sname(i), ira1(i), ira2(i), ra3(i), signn(i &), id1(i), id2(i), id3(i), epold(i), data1(i) write(unit=2, fmt=279) jra1(i), jra2(i), r3(i), newsignn(i), jd(i) &, dj2(i), data2(i) 199 continue close(unit=2) c # 418 "obsprepnew.f" 305 goto 310 # 422 "obsprepnew.f" 181 lt(1) = 18. do 159 i = 1, 12 lt(i + 1) = lt(i) + 1. 159 continue # 428 "obsprepnew.f" do 163 i = 1, n rahr(i) = (ira1(i) + (ira2(i) / 60.)) + (ra3(i) / 3600.) c IF(ID1(I).LT.0)THEN c D2(I)=-D2(I) # 430 "obsprepnew.f" ra0(i) = (rahr(i) * pi) / 12. # 434 "obsprepnew.f" if (signn(i) .eq. '-') then id3(i) = - id3(i) id2(i) = - id2(i) id1(i) = - id1(i) # 438 "obsprepnew.f" else end if ddg(i) = id1(i) + (id2(i) / 60.) + (id3(i) / 3600.) d0(i) = (ddg(i) * pi) / 180. t(i) = (epnew - epold(i)) / 100. zet0(i) = ((2304.948 * t(i)) + (0.302 * (t(i) ** 2))) + (0.0179 * &(t(i) ** 3)) # 444 "obsprepnew.f" z(i) = ((2304.948 * t(i)) + (1.093 * (t(i) ** 2))) + (0.0192 * (t( &i) ** 3)) # 445 "obsprepnew.f" th(i) = ((2004.255 * t(i)) - (0.426 * (t(i) ** 2))) - (0.0416 * (t &(i) ** 3)) # 446 "obsprepnew.f" rzet0(i) = ((zet0(i) / 3600.) * pi) / 180. rz(i) = ((z(i) / 3600.) * pi) / 180. rth(i) = ((th(i) / 3600.) * pi) / 180. raz(i) = ra0(i) + rzet0(i) a(i) = rth(i) / 2 q(i) = sin(rth(i)) * (tan(d0(i)) + (cos(raz(i)) * tan(a(i)))) dam(i) = (q(i) * sin(raz(i))) / (1 - (q(i) * cos(raz(i)))) fm(i) = rzet0(i) + rz(i) da(i) = atan(dam(i)) + fm(i) c(i) = (da(i) - fm(i)) / 2. b(i) = raz(i) + c(i) tt(i) = (tan(a(i)) / cos(c(i))) * cos(b(i)) dd(i) = atan(tt(i)) # 460 "obsprepnew.f" 3 d(i) = (2. * dd(i)) + d0(i) ra(i) = ra0(i) + da(i) ra1(i) = (ra(i) * 12.) / pi d1(i) = (d(i) * 180.) / pi jra1(i) = ifix(ra1(i)) r2(i) = (ra1(i) - jra1(i)) * 60. jra2(i) = ifix(r2(i)) r3(i) = (((ra1(i) - jra1(i)) * 60.) - jra2(i)) * 60. jd(i) = ifix(d1(i)) c c CALCULATE AIRMASS AS A FUNCTION OF THE LOCAL OBSERVING TIME c # 469 "obsprepnew.f" dj2(i) = (d1(i) - jd(i)) * 60. # 475 "obsprepnew.f" 666 continue # 478 "obsprepnew.f" do 166 k = 1, 13 # 480 "obsprepnew.f" ut = lt(k) + utd dys = days if ((sflag .eq. 0) .or. (dflag .eq. 1)) ut = ut - 1. if (ut .ge. 24) then dys = days + 1 ut = ut - 24. else end if c c GMST for observing date # 488 "obsprepnew.f" ddys = float(dys) c gmst = (k1 + (k2 * ddys)) + (k3 * ut) # 494 "obsprepnew.f" 160 if (gmst .ge. 24) goto 161 175 goto 176 161 gmst = gmst - 24. goto 160 c # 498 "obsprepnew.f" 176 continue c WRITE(*,668)LT(K),GMST,DYS # 502 "obsprepnew.f" flst = gmst - flonhr # 506 "obsprepnew.f" 668 format(x,f3.0,2x,f7.4,2x,i3) # 509 "obsprepnew.f" 667 continue # 513 "obsprepnew.f" hahr(i) = ((ra(i) * 12.) / pi) - flst ha(i) = (hahr(i) * pi) / 12. cosz = (sin(flat) * sin(d(i))) + ((cos(flat) * cos(d(i))) * cos(ha &(i))) if (cosz .le. 0.03) goto 21 secz = 1 / cosz x(i,k) = ((secz - (0.001867 * (secz - 1))) - (0.002875 * ((secz - &1) ** 2))) - (0.0008083 * ((secz - 1) ** 3)) goto 166 21 x(i,k) = 00.00 166 continue if ((signn(i) .eq. '-') .and. (dj2(i) .gt. 0)) newsignn(i) = '+' if (dj2(i) .lt. 0.) dj2(i) = - dj2(i) if (id3(i) .lt. 0) id3(i) = - id3(i) if (id2(i) .lt. 0) id2(i) = - id2(i) if (id1(i) .lt. 0) id1(i) = - id1(i) if (jd(i) .lt. 0) jd(i) = - jd(i) 163 continue c write(unit=*, fmt=374) 374 format(/10x, &53h*** PRECESSION and AIRMASS calculations COMPLETED ***) c c WRITE OUTPUT FILE (OUTPUT FORMAT) c write(unit=*, fmt=333) call wopen(2, 'Output file (with AIRMASS information)') obsy = obsy + 1900 write(unit=2, fmt=101) obsm, obsd, obsy, label c 101 format(1h1,70x,21hLocal Observing Day: ,i2,1h/,i2,1h/,i4,3x,a4) 101 format(50x,21hLocal Observing Day: ,i2,1h/,i2,1h/,i4,3x,a4) write(unit=2, fmt=103) timez write(unit=2, fmt=100) 103 format(x/,55x,31hAirmass (X) for LOCAL TIME in *,a3, &11h* TIME ZONE) # 543 "obsprepnew.f" c 100 format(/,4x, c &118hStar RA Dec Notes 18 19 20 21 c & 22 23 24 1 2 3 4 5 6) c 123456789112345678921234567893123456789412345678951234567896123456 do 167 i = 1, n write(unit=2, fmt=104) write(unit=2, fmt=168) sname(i), jra1(i), jra2(i), r3(i), newsignn &(i), jd(i), dj2(i), data1(i), (x(i,k),k = 1, 13) c 168 format(x,a9,2i3,f5.1,2x,a1,i2,f5.1,2x,a11,f5.2,12f6.2) 168 format(a9,2i3,f5.1,x,a1,i02,f05.1,2x,a21,f5.2,12f6.2) write(unit=2, fmt=169) epold(i), ira1(i), ira2(i), ra3(i), signn(i &), id1(i), id2(i), id3(i), data2(i) c 169 format(x,3hOLD,f6.1,2i3,f5.1,2x,a1,i2,x,i2,x,i2,x,a11) 169 format(3hOLD,f6.1,2i3,f05.1,x,a1,i02,x,i02,x,i02,x,a21) # 556 "obsprepnew.f" 104 format(129h------------------------------------------------------- &------------------------------------------------------------------ &--------) c 123456789112345678921234567893123456789412345678951234567896123456 100 format(129h Star RA Dec Notes 1 &8 19 20 21 22 23 24 1 2 3 4 5 & 6 ) # 559 "obsprepnew.f" 167 continue write(unit=2, fmt=104) write(unit=2, fmt=100) c write(unit=2, fmt=170) c 170 format(/,62x, c &60hNOTE: X=0 Means the STAR is close to or BELOW the HORIZON) c write(unit=2, fmt=171) obsm, obsd, obsy, label c 171 format(//,70x,26hEnd of the STAR list for: ,i2,1h/,i2,1h/ c &,i4,3x,a4) close(unit=2) *F77CVT -- VMS feature: TYPE statement # 567 "obsprepnew.f" c 400 write(unit=*, fmt=401) c 401 format(/x, c &66hWould you like to see just the PRECESSED coordinate &s? $) cc IF(ANSWER.EQ.'NO '.OR.ANSWER.EQ.'N ')GO TO 310 c# 570 "obsprepnew.f" c read(unit=*, fmt=20, err=400, end=1000) answer c# 572 "obsprepnew.f" c call yesno(answer, yn) c if (yn .eq. 0) goto 310 goto 310 ccc goto 299 c c # 575 "obsprepnew.f" 1000 stop end c c open a file for output c parameters: prompt - the user's prompt c unit - unit number for output c subroutine wopen(unit, prompt) character filnam*250 character prompt*(*) integer unit, length # 587 "obsprepnew.f" 1 write(unit=*, fmt=2) prompt 2 format(x,a,1h:,$) read(unit=*, fmt=3, end=100, err=1) length, filnam 3 format(q,a) if (length .eq. 0) goto 1 open(unit=unit *F77CVT -- VMS feature: NAME= specifier in OPEN &, file=filnam *F77CVT -- VMS feature: TYPE= specifier in OPEN &, status='new', err=50) # 593 "obsprepnew.f" return 50 write(unit=5, fmt=4) filnam(1:length) 4 format(31h UOFWOP - Unable to open file ",a,1h") goto 1 100 stop c c # 598 "obsprepnew.f" end c c open a file for input c parameters: prompt - the user's prompt c unit - unit number for input c subroutine ropen(unit, prompt) character filnam*250 character prompt*(*) integer unit, length # 610 "obsprepnew.f" 1 write(unit=*, fmt=2) prompt 2 format(x,a,1h:,$) read(unit=*, fmt=3, end=100, err=1) length, filnam 3 format(q,a) if (length .eq. 0) goto 1 open(unit=unit *F77CVT -- VMS feature: NAME= specifier in OPEN &, file=filnam *F77CVT -- VMS feature: TYPE= specifier in OPEN &, status='old', err=50) # 616 "obsprepnew.f" return 50 write(unit=5, fmt=4) filnam(1:length) 4 format(31h UOFROP - Unable to open file ",a,1h") goto 1 100 stop c c c # 621 "obsprepnew.f" end subroutine yesno(answer, yn) character answer*3 # 627 "obsprepnew.f" yn = 1 if ((answer .eq. 'NO ') .or. (answer .eq. 'N ')) yn = 0 if ((answer .eq. 'no ') .or. (answer .eq. 'n ')) yn = 0 if (answer .eq. '0 ') yn = 0 return end c CHANGES FROM "OLDPREP" TO CURRENT VERSION: c c line#/change c c 61 added id2 and id3 to dimension list c 334 changed Dg Mn.X to Dg Mn Ss c 335 changed d2 to id2 & added id3 c 337 changed from (a1,i2,f5.1) to (a1,i2,i2,i2) c 370 changed to write out id2 & id3, not just d2 c 407 changed to read in id2 & id3, not just d2 c 411 changed format to have id2 & id3, not just d2 c 426 changed to write out id2 & id3, not just d2 c 456 changed to print out id2 & id3, not just d2 c 457 changed format to have id2 & id3, not just d2 c 479 changed to write out id2 & id3, not just d2 c 503 changed to include id2 & id3 instead of d2 c 509 changed to calculate declination w/id2 & id3, not just d2 c 627-8 changed to output proper new format c2345678911234567892123456789312345678941234567895123456789612345678971234567898 c23456789112345678921234567893123456789412345678951234567896123456789