Dark Count Correction Program

  73 )                          OS/360  FORTRAN H

CER OPTIONS - NAME=  MAIN,OPT=02,LINECNT=58,SIZE=0000K,
C             SOURCE,EBCDIC,NOLIST,NODECK,LOAD,MAP,NOEDIT,ID,XREF
      DEFINE FILE 32(72,665,U,K32)
C   IF MON=1,U2 WAVELENGTHS WILL BE REPLACED BY U1 WAVELENGTHS FOR USE BY
C   THE STACKING PROGRAM.
      DIMENSION INFO(5500),LEN(3),TABLE( 7,95),WI(350),TIME(350),
     X     BACK(350),TOT(350),STAT(3,350),IWLT(350),ICS(350),ITIM(350),
     X     AWL(350),LTIME(350),IJJ(350),III(350),RATIO(10,3),JOF(7,95)
      DATA RATIO/1.8,1.38,1.21,1.12,1.06,1.03,1.01,1.,1.,1.,2.68,1.74,
     1 1.41,1.24,1.13,1.06,1.03,1.01,1.,1.,1.5,1.29,1.17,1.10,1.05,1.03
     2 ,1.02,1.01,1.,1./
      LOGICAL*1 STAT,USTNR
      INTEGER*4 TABLE
      COMPLEX*16 NAME(4)/
     1'STAR NR         ',
     2'LAN             ',
     3'TUBE NR         ',
     4'ORBIT           '/
      COMMON /TROUT/ JNFO(100),STARN
      COMMON/PSCALE/ MULT,F1,F2,F3
      NAMELIST/INPUT/ IFMON,VSHIFT,KJUMP,KQUIT,STNR,USTNR
      CALL INDUMP

C  INITIALIZATION
      KQUIT=100000
      VSHIFT=0.0
      USTNR=.FALSE.
      STNR=0.00
      SPDLHT=300000.0
C                     KM/SEC
      NPTS1=0
      ATIME=0.
      NSER1=0
      IFMON=0
      N=4
      IFLAG=0
      KJUMP=0
      NSER=0
      LL=0
      JS=0
      TINE=0
      JTINE=0
      CALL SETUP(N,NAME,LEN,&1000)
      READ(5,INPUT)
      WRITE(6,INPUT)
      MON=IFMON
  100 CONTINUE
C  PROGRAM CHECKS TO SEE IF IT SHOULD JUMP TO A SERIAL NO. OR START AT THE
C     BEGINNING.
      IF(KJUMP.EQ.0) GO TO 299
      CALL HEADER(5500,INFO,&1001)
      WRITE(6,30)
   30 FORMAT(2X,'HEADER1')
      CALL JUMP(KJUMP,&1001)
      NSER=NSER+KJUMP
  299 NSERO=NSER+1
C  HEADER CALLS CONTROLLED HERE, INCLUDING CHECKS TO SEE IF KQUIT HAS BEEN
C     REACHED OR TO SEE IF "STAR NUMBER" LOGIC IS TO BE USED.  IF USTNR
C     ("USE STAR NUMBER") IS .TRUE., CHECK FOR STAR NUMBER IS MADE.
  300 NSER=NSER+1
      IF(NSER.GT.KQUIT) GO TO 1002
      CALL HEADER(5500,INFO,&1001)
      IF(.NOT.USTNR) GO TO 413
      IF(STNR.EQ.0.00) GO TO 1003
      CALL ANUM(INFO,1,SNR)
      IF(SNR.NE.STNR) GO TO 300
  413 CALL SCAN(NPTS,WL,TIME,BACK,TOT,STAT)
      CALL INUM(INFO,3,NTB)
      IF(ABS(WL(NPTS) - WI(1)) .GT. .16 .AND. NTB .EQ.3) MON = 0
  110 CALL ANUM(INFO,2,RLAN)
C  IN THIS SECTION THE TIME DEPENDENCE IS TAKEN INTO ACCOUNT.  DATA IN THE
C     "DATA RATIO" CARDS AT THE BEGINNING OF THE PROGRAM, SPECIFIED EVERY 500
C     ORBITS FROM 0 TO 4500 FOR V1, V2, AND V3 RESPECTIVELY ARE USED TO INFER
C     "FACT."
      CALL INUM(INFO,4,KTOB)
      IF(KTOB.GT.4000) GO TO 298
      IF(NTB.EQ.1)GO TO 298
      IF(NTB.EQ.3)GO TO 298
      IF(NTB.EQ.6)GO TO 298
      IF(NTB.EQ.2) M=1
      IF(NTB.EQ.4) M=2
      IF(NTB.EQ.5) M=3
      LT=KTOB/500
      KT2=LT*500
      AKDT=KTOB-KT2
      AKDT=AKDT/500.
      LT=LT+1
      FACT=RATIO(LT,M)+AKDT*(RATIO(LT+1,M)-RATIO(LT,M))
      GO TO 297
  298 FACT=1.0
  297 CONTINUE
C  THE STANDARD ORBIT AND MINUTE DATA FOR THE FIRST DATA POINT ARE INFERRED,
C     FOR PURPOSES OF PRINTOUT.
      RL=-RLAN
      RKK=TIME(1)/380.
      KK=IFIX(RKK)
      RL=RL-KK*(+25.335)
      IF(RL.LT.0.0) RI=RI+360.0
      RL1=RL
      KU=RL/5 +1
      READ(32'KU) TABLE
      KR=(TIME(1)-(KK*380.)-2)/4+1
      IF(TIME(1).LE.1) KR=0
      KU1=KU
C  THE DARK COUNT DATA FOR EACH POINT OF THE SCAN ARE DERIVED.  LINEAR
C     INTERPOLATION IN THE TABLE IS USED, WITH MAIN TABULATED POINTS
C     CORRESPONDING TO 1.5 SETS INTO STANDARD ORBIT, 5.5, 9.5, 13.5, ETC.
C     FOR SETS 0,1 (378,379), THE LAST POINT (FIRST POINT) OF THE LAST (NEXT)
C     STANDARD ORBIT IS  USED TO MAKE THE CROSSING INTO A NEW ORBIT IN THE
C     TABLE SMOOTH.
      DO 200 I=1,NPTS
      RL=-RLAN
      RKK=TIME(I)/380.
      KK=IFIX(RKK)
      RL=RL-KK*(+25.335)
      IF(RL.LT.0.0) RL=RL+360.0
      II=RL/5 +1
      IF(II.NE.KU) READ(32'II) TABLE
      IF(II.NE.KU) KU=II
      TINE=(TIME(I)-KK*380.)
      JTINE=TINE
      JJ=(JTINE-2)/4+1
      IF(JTINE.LE.1) JJ=0
      IF(II.GT.72.OR.JJ.GT.95) GO TO 305
      IF(JJ.EQ.JS) GO TO 405
      IF(TINE.GT.1) GO TO 404
      KN=(RL+25.335)/5+1
      READ(32'KN) JOF
      ZBK1=JOF(NTB,95)
      ZBK2=(TABLE(NTB, 1)-ZBK1)/4.
      GO TO 405
  404 IF(TINE.LT.378) GO TO 406
      ZBK1=TABLE(NTB,JJ)
      KN=(RL-25.335)/5+1
      READ(32'KN) JOF
      ZBK2=(JOF(NTB,1)-ZBK1)/4.
      GO TO 405
  406 NMJ=JJ+1
      ZBK1=TABLE(NTB,JJ)
      ZBK2=(TABLE(NTB,NMJ)-ZBK1)/4.
  405 GJJ=JJ
      GIT=TINE-4.*GJJ+2.5
      BACK(I)=(ZBK1+ZBK2*GIT)/FACT
      JS=JJ
C  IF "IFMON" IS 1 (SEE NAME LIST), U1 WAVELENGTHS ARE EQUATED TO U2
C     WAVELENGTHS.
      IF(MON.EQ.1.AND.NTB.EQ.1) AWL(I)=WI(I)
      IF(MON.EQ.1.AND.NTB.EQ.3) WL(I)=AWL(I)
  401 STAT(1,I)=.TRUE.
      ITIM(I)=TIME(I)
      IF(TABLE(7,JJ).EQ.0) GO TO 200
      LL=LL+1
      LTIME(LL)=I
      LJJ(LL)=JJ
      LII(LL)=II
  200 CONTINUE
C     ENCODE COMMENTS ON NATURE OF BACKGROUNDS
      IC1=JNFO(10)/1000000
      I=JNFO(10)-1000000*IC1
      IC2=I/10000
      I=I-10000*IC2
      IC3=I/100
      IC4=I-100*IC3
      IC1=19
      IF(LL.GT.0) IC1=18
      JNFO(10)=(IC1*1000000)+(IC2*10000)+(IC3*100)+IC4
      JS=0
      IF(NSER.NE.NSERO)GO TO 39
      WRITE(6,40)
      WRITE(6,41)
   40 FORMAT('1','NSER',3X,'LAN',2X,'NTB',1X,'TIME',3X,'TOT',4X,'BACK',2
     2X,'STAT',2X,'LAN',3X,'ORB',1X,'TIME',1X,'NPT',2X,'FACTOR',2X,
     3 'ORBIT')
   41 FORMAT(7X,'SMART',31X,'GSFC')
   39 WRITE(6,10) NSER,RLAN,NTB,TIME(1),TOT(1),BACK(1),(STAT(J,1),J=1,3)
     1  ,RL1,KU1,KR,NPTS,FACT,KTOB
   10 FORMAT(1X,I5,F7.2,1X,I1,1X,F4.0,2F8.1,1X,3L1,1X,F7.2,1X,2I3,1X,I4,
     1 F9.2,I7)
   38 IF(LL.EQ.0)GO TO 228
      IF(TIME(1).NE.ATIME)GO TO 47
      IF(NPTS1.EQ.NPTS)GO TO 48
   47 WRITE(6,11)(LTIME(I),III(I),IJJ(I),I=1,LL)
   11 FORMAT(10(I4,1X,'(',I2,',',I2,')'))
      GO TO 49
   48 WRITE(6,12) NSER1
   12 FORMAT(4X,'ANOMALY EFFECTS AS FOR NSER=',I6)
   49 LL=0
      LL=0
  228 CONTINUE
C  STATUS FLAGS SET IN HEADER.
      IF(MOD(JNFO(7)/268435456,2).EQ.0) JNFO(7)=JNFO(7)+268435456
      IF(MOD(JNFO(8)/268435456,2).EQ.0) JNFO(8)=JNFO(8)+268435456

C     NOW DO SOME VSHIFT LOGIC

  225 IF(VSHIFT.EQ.0.0.OR.NTB.EQ.5.OR.NTB.EQ.6) GO TO 227
      DO 226 KK=1,NPTS
  226 WL(KK)=WL(KK)+(VSHIFT/SPDLHT)*WI(KK)
      CALL QWLTIM(1,JNFO(4),WL(1),ITIM(1))
      CALL QWLTIM(1,JNFO(5),WI(NPTS),ITIM(NPTS))
  227 CALL QWLTIM(NPTS,IWLT,WL,ITIM)
      CALL QCOUNT(NPTS,ICS,BACK,TOT,STAT,FLOAT(MULT))
      IF(MON.EQ.0.OR.NTB.NE.3) GO TO 402
      CALL QWLTIM(1,JNFO(4),AWL(1),ITIM(1))
      CALL QWLTIM(1,JNFO(5),AWL(NPTS),ITIM(NPTS))
  402 WRITE(60   )  STARN,(JNFO(KK),KK=1,12)
      WRITE(60   ) NPTS,(IWLT(K),ICS(K),K=1,NPTS)
   20 FORMAT(4(100A4))
      ATIME=TIME(1)
      NSER1=NSER
      NPTS1=NPTS
      IF(IFMON.EQ.1) MON=1
      GO TO 300
 1000 CONTINUE
      WRITE(6,23) N
   23 FORMAT('0*** BLEW IT IN SETUP. N=',I3,' ***')
      STOP 777
 1003 CONTINUE
      WRITE(6,24)
   24 FORMAT(3X,'STAR NUMBER NEEDED BUT NOT SPECIFIED')
      STOP 888
 1001 CONTINUE
      WRITE(6,21) NSER
   21 FORMAT('0*** END OF DATA SET. NSER=',I6,' ***')
  301 STOP 100
 1002 WRITE(6,22) NSER
   22 FORMAT('0*** END OF BACKGROUND REWRITE REQUEST. NSER= ',I6,' ***')
      STOP 100
  305 WRITE(6,306) II,JJ
  306 FORMAT('0INDICES FOR TABLE HAVE GOTTEN OUT OF RANGE.  SUGGEST MAKIN
     XG AN ABBREVIATED RUN WITH FULL OUTPUT.  II=',I7,5X,'JJ=',I7)
      STOP 999
      END


Return to main paper.