C MAIO 4 C MAIO 5 C "PREPAR " - AUTHOR - P.G. LAWNIKANIS MAIO 6 C - COAUTHOR - J. KOUBA MAIO 7 C - WRITTEN ON - DECEMBER /74. MAIO 8 C - LAST COMPILED - NOVEMBER /75. MAIO 9 C - REFERENCES - *NONE* MAIO 10 C MAIO 11 C EXTERNAL ROUTINES -TIMII ,RMERGE ,TIMIP , MAIO 12 C DATE ,ERRSET ,EOF ,EXIT MAIO 13 C MAIO 14 C I/O DEVICES -IRED = CARD READER MAIO 15 C IPRT = LINE PRINTER MAIO 16 C IEPH = SOURCE EPHEMERIS DATA MAIO 17 C INPT = SOURCE RAW DATA MAIO 18 C IOUT = OUTPUT DATA MAIO 19 C MAIO 20 C MAIO 21 C ›PREPAR› READS AND MERGES GEOCEIVER OR TRACKING-VAN DOPPLER MAIO 22 C DATA WITH NWL-FITTED (PRECISE) OR PREDOP EPHEMERIS. MAIO 23 C MAIO 24 IMPLICIT REAL*8(A-H,O-Z) REAL*8 NAME REAL*8 MESS REAL*8 ISRC REAL*8 IEPN,ISTN LOGICAL*1 TDATE(18),DAYT(10),CODE(6),TIME2(6),SLASH,BLANK COMMON NAME , ISRC , ISAT , INJC , LOKR , LENG , FSAT , NSTN MAIO 25 + , ORBP , IFIT , COEF , NDOP , ISTN , PRES , TDRY , VPAR MAIO 26 + , DOPP , TIME , IFLG , NSAT , NORD , ISWT , LOKG , KDOP MAIO 27 + , NPSI , NPSA , NDPI , NDPA , IRCV , INTA MAIO 28 COMMON /DEV/ IEPH , INPT , IOUT , IRED , IPRT MAIO 29 COMMON /PAR/ DAYP , TPER , XMOT , APTP , DATP , ECCT , RAAN MAIO 30 + , DRAN , RAGR , ANGL , JSAT , IEPO , PERD MAIO 31 COMMON /TIM/ A , B , ALOK , DTAU , EXPT , GXYZ , IORD MAIO 32 + , MESS , SIGS , TTAU , VPVP , FREQ , TAUT MAIO 33 DIMENSION ORBP( 7) , COEF(30) , DOPP(50) , TIME(50) , KDOP(50) MAIO 34 + , INTA(30) MAIO 35 DIMENSION GXYZ( 3) , EXPT(99) , A(3,2) , B(3,3,3) , MESS( 3) MAIO 36 + , TAUT(10) MAIO 37 DIMENSION IEPN( 2) , TYPE( 2) , INTB(20) MAIO 38 DATA SLASH/'/'/, BLANK/' '/ DATA TYPE/8H GEOCEIV,8H TRANET/ + ,IEPN/8HBROADCAS, 8HNWL-PREC/ + , PITW / 6.28318531 / , RADN / .0174532925 / MAIO 43 + , INTB / 12 , 13 , 14 , 15 , 16 , 17 , 18 , 0 , 0 , 0 MAIO 44 + , 19 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 20 / MAIO 45 C MAIO 46 DO 1 I=1,7 1 ORBP(I)=0.D0 INJC=0 IFIT=0 PERD=104.D0 TPER=0.D0 CALL GDATE(TDATE,TIME2,CODE) J=1 DO 2 I=1,8 IF(I.NE.3.AND.I.NE.6) GO TO 3 DAYT(I)=SLASH GO TO 2 3 DAYT(I)=CODE(J) J=J+1 2 CONTINUE DAYT(9)=BLANK DAYT(10)=BLANK DO 100 I = 1,20 MAIO 48 INTA(I) = INTB(I) MAIO 49 100 CONTINUE MAIO 50 IEOF=0 10 IF(IEOF.NE.0) STOP READ(IRED,5,END=98)IRCV,IPRN,IFLG,KSAT,ISTN,GXYZ,EXPT(1) 1,(EXPT(I),I=2,4),EXPT(5),(EXPT(I),I=6,8) GO TO 11 98 IEOF=1 11 IF(IRCV.GT.1) CALL EXIT IF (KSAT.GT.50) KSAT = INTA(KSAT - 57) MAIO 55 MAXD=IPRN IF(MAXD.EQ.0) MAXD=32 READ(IEPH,END=99) NSTN,NSAT,LOKR,NAME,DAIT,ISRC,IDUM,IORD IF(ISRC.NE.IEPN(1))ISRC=IEPN(2) IEPO = 1 MAIO 59 NSTN = 1 MAIO 60 IFLG = IFLG + 1 MAIO 61 IRCV = IRCV + 1 MAIO 62 NORD = IORD * 3 MAIO 63 WRITE (IPRT,15) DAYT , TYPE(IRCV) , DAYT , NAME , NSTN , DAIT MAIO 64 + , IORD , ISRC , ISTN , GXYZ MAIO 65 IF(ISRC.EQ.IEPN(1)) GO TO 12 C MAIO 67 IEPO = 2 MAIO 68 NSAT = INTA (NSAT - 57) MAIO 69 IF (KSAT.NE.NSAT) CALL EXIT MAIO 70 IF(IEOF.NE.0) GO TO 12 READ(IRED,35,END=12)DAYP , TPER, XMOT, APTP, DATP, ECCT, RAAN + , DRAN , RAGR , ANGL , FSAT , JSAT MAIO 72 WRITE (IPRT,45) DAYP , TPER , XMOT , APTP , DATP , ECCT , RAAN MAIO 73 + , DRAN , RAGR , ANGL , FSAT , JSAT MAIO 74 DAYP = DAYP * 1440. MAIO 75 TPER = TPER + DAYP MAIO 76 XMOT = XMOT * RADN MAIO 77 APTP = APTP * RADN MAIO 78 DATP = DATP * RADN * 1E-7 MAIO 79 RAAN = RAAN * RADN MAIO 80 DRAN = DRAN * RADN * 1E-7 MAIO 81 RAGR = RAGR * RADN MAIO 82 ANGL = ANGL * RADN MAIO 83 FSAT = FSAT * 4E-1 MAIO 84 INJC=IDINT(TPER) JUL80004 IF(XMOT.GT.1.E-6) PERD=PITW/XMOT C MAIO 87 ORBP(2) = XMOT MAIO 88 ORBP(3) = ECCT MAIO 89 ORBP(7) = ANGL MAIO 90 C MAIO 91 12 WRITE (IOUT) NAME , IORD , DAYT , NSTN , ISRC MAIO 92 LOKG = 0 MAIO 93 NPSI = 0 MAIO 94 NPSA = 0 MAIO 95 NDPI = 0 MAIO 96 NDPA = 0 MAIO 97 NSAT = KSAT MAIO 98 CALL TIMII MAIO 99 CALL RMERGE MAIO 100 40 WRITE (IPRT,25) NPSI , NPSA , NDPI , NDPA MAIO 101 CALL TIMIP MAIO 102 GO TO 10 MAIO 103 C MAIO 104 5 FORMAT(4(3X,I2),A8,3F10.1,4F5.1/4F5.1) 15 FORMAT(1H1,/,5X,10A1,20X,25H** PREPARE GEODOP INPUT (,A8,4H) **, + 20X,10A1,//,24H SOURCE EPHEMERIS ... ,2(A8,I3) + ,10H ....... (,A8,1H) + ,//,13H STATION - ,A8 + ,//,15H COORDINATES ,3F15.1) 25 FORMAT (////,21H # PASSES READ = ,I4 MAIO 111 + ,/,21H # PASSES USED = ,I4 MAIO 112 + ,/,21H # DOPPLERS READ = ,I4 MAIO 113 + ,/,21H # DOPPLERS USED = ,I4 MAIO 114 +) MAIO 115 35 FORMAT(F3.0,F9.4,F9.7,F8.4,F6.0,F7.6,F8.4,F5.0,F8.4,F8.5,F6.0,I3)MAIO 116 45 FORMAT ( /,24H KEPLERIAN PARAMETERS MAIO 117 + ,F5.0,F11.4,F11.7,F10.4,F8.0,F9.6,F10.4,F7.0,F10.4,F10.5,F8.0,I5)MAIO 118 C MAIO 119 99 STOP JUL80005 END MAIO 120 BLOCK DATA IMPLICIT REAL*8(A-H,O-Z) REAL*8 MESS DIMENSION GXYZ( 3) , EXPT(99) , A(3,2) , B(3,3,3) , MESS( 3) M + , TAUT(10) COMMON /DAT/ IFRQ,MAXD COMMON /TIM/ A , B , ALOK , DTAU , EXPT , GXYZ , IORD + , MESS , SIGS , TTAU , VPVP , FREQ , TAUT COMMON /DEV/ IEPH,INPT,IOUT,IRED,IPRT DATA IEPH/3/, INPT/4/, IOUT/2/, IRED/5/, IPRT/6/ DATA MAXD/32/ DATA GXYZ,EXPT,A,B,TAUT/145*0.D0/ DATA MESS/3*1H / DATA ALOK,DTAU,SIGS,TTAU,VPVP,FREQ/6*0.D0/ END SUBROUTINE RMERGE GEOC 2 C GEOC 3 C GEOC 4 C "RMERGE " - AUTHOR - P.G. LAWNIKANIS GEOC 5 C - WRITTEN ON - DECEMBER /74. GEOC 6 C - LAST COMPILED - NOVEMBER /75. GEOC 7 C - REFERENCES - *NONE* GEOC 8 C GEOC 9 C VARIABLES USED -IRCV ,ISWT ,LOKR ,LOKG GEOC 10 C NDOP ,NPSI ,ISAT ,DTAU GEOC 11 C SIGS ,TDRY ,VPAR ,PRES GEOC 12 C NTIM ,KDOP ,MESS ,IOUT GEOC 13 C GEOC 14 C VARIABLES ALTERED -KDOP , , , GEOC 15 C GEOC 16 C VARIABLES RETURNED -*NONE* , , , GEOC 17 C GEOC 18 C EXTERNAL ROUTINES -READGE ,READTR ,READEF ,WRITE5 GEOC 19 C DDHHMM ,MODULO , , GEOC 20 C GEOC 21 C I/O DEVICES -IPRT , , , GEOC 22 C GEOC 23 C GEOC 24 IMPLICIT REAL*8(A-H,O-Z) JUL80003 REAL*8 NAME REAL*8 MESS REAL*8 ISRC,ISTN COMMON NAME , ISRC , ISAT , INJC , LOKR , LENG , FSAT , NSTN GEOC 25 + , ORBP , IFIT , COEF , NDOP , ISTN , PRES , TDRY , VPAR GEOC 26 + , DOPP , TIME , NTIM , NSAT , NORD , ISWT , LOKG , KDOP GEOC 27 + , NPSI , NPSA , NDPI , NDPA , IRCV GEOC 28 COMMON /DEV/ IEPH , INPT , IOUT , IRED , IPRT GEOC 29 COMMON /TIM/ A , B , ALOK , DTAU , EXPT , GXYZ , IORD GEOC 30 + , MESS , SIGS , TTAU , VPVP , FREQ , TAUT GEOC 31 DIMENSION ORBP( 7) , COEF(30) , DOPP(50) , TIME(50) , KDOP(50) GEOC 32 DIMENSION GXYZ( 3) , EXPT(99) , A(3,2) , B(3,3,3) , MESS( 3) GEOC 33 + , TAUT(10) GEOC 34 DIMENSION ISPN ( 3) GEOC 35 DATA MAXW / 7 / , ILIN / 1 / , MINL / 10 / GEOC 38 C GEOC 39 10 ISKP = 1 GEOC 40 C GEOC 41 20 GO TO (22 , 32) , IRCV GEOC 42 C GEOC 43 22 CALL READGE GEOC 44 GO TO (40 , 50) , ISKP GEOC 45 C GEOC 46 32 CALL READTR GEOC 47 GO TO (40 , 50) , ISKP GEOC 48 C GEOC 49 40 CALL READEF GEOC 50 50 GO TO (40 , 60 , 60 , 100 , 100 , 100) , ISWT GEOC 51 C GEOC 52 60 ISKP = 2 GEOC 53 IF ((LOKR - LOKG + 4) / MAXW) 40 , 80 , 20 GEOC 54 C GEOC 55 80 CALL WRITE5 GEOC 56 CALL DDHHMM (LOKG , ISPN) GEOC 57 ILIN=MOD(ILIN,59)+1 JUL80002 IF (ILIN.EQ.2) WRITE (IPRT, 5) GEOC 59 ISKP = NDOP + 1 GEOC 60 DO 200 I = ISKP,32 GEOC 61 200 KDOP(I) = 0 GEOC 62 WRITE (IPRT,15) NPSI , ISAT , ISPN , DTAU , SIGS , NTIM , TDRY GEOC 63 + , VPAR , PRES , (KDOP(I),I=1,32) , MESS GEOC 64 GO TO (10 , 10 , 100) , ISWT GEOC 65 C GEOC 66 100 ENDFILE IOUT GEOC 67 RETURN GEOC 68 C GEOC 69 5 FORMAT (50H1PASS SAT LOKON DLAY SIGS NO. DRY GEOC 70 + ,10HPAR PRESS,10X,25HU S E D D O P P L E R S ,18X GEOC 71 + ,13HN O T E S) GEOC 72 15 FORMAT (3I5,2(1H/,I2),F9.3,F7.3,I4,F7.0,F5.0,F7.0,2X,8(1X,4I1),2XGEOC 73 + ,3A8) END GEOC 75 SUBROUTINE READGE REDG 2 C REDG 3 C REDG 4 C "READGE " - AUTHOR - P.G. LAWNIKANIS REDG 5 C - WRITTEN ON - DECEMBER /74. REDG 6 C - LAST COMPILED - NOVEMBER /75. REDG 7 C - REFERENCES - GEOCEIVER OPERATIONS MANUAL(APL)REDG 8 C REDG 9 C VARIABLES USED -NDPI ,INPT ,NPSI ,IFLG REDG 10 C NSAT ,ISWT ,NDPA ,NDOP REDG 11 C INTA REDG 12 C REDG 13 C VARIABLES ALTERED -ISWT ,NDOP ,ISAT ,NPSI REDG 14 C LOKG ,TTAU ,TDRY ,PRES REDG 15 C VPAR ,DOPP ,TIME ,KDOP REDG 16 C NDPI ,NDPA ,NDOP , REDG 17 C REDG 18 C VARIABLES RETURNED -*NONE* , , , REDG 19 C REDG 20 C EXTERNAL ROUTINES -MINUT , , , REDG 21 C EOF ,FLOAT ,INT ,(DECODE) REDG 22 C REDG 23 C I/O DEVICES -INPT , , , REDG 24 C REDG 25 C REDG 26 IMPLICIT REAL*8(A-H,O-Z) JUL80001 REAL*8 NAME REAL*8 MESS REAL*8 LINE(3),IBLK,ISLS,BUFFER,ISRC,ISTN INTEGER*2 HSLS,HHDR,IHDT,IHDR,MASS,MASI DIMENSION LINE3(2) DIMENSION INTA(30),BUFFER(5) JUL80003 COMMON NAME , ISRC , ISAT , INJC , LOKR , LENG , FSAT , NSTN REDG 27 + , ORBP , IFIT , COEF , NDOP , ISTN , PRES , TDRY , VPAR REDG 28 + , DOPP , TIME , IFLG , NSAT , NORD , ISWT , LOKG , KDOP REDG 29 + , NPSI , NPSA , NDPI , NDPA , IRCV , INTA REDG 30 COMMON /DEV/ IEPH , INPT , IOUT , IRED , IPRT REDG 31 COMMON /TIM/ A , B , ALOK , DTAU , EXPT , GXYZ , IORD REDG 32 + , MESS , SIGS , TTAU , VPVP REDG 33 COMMON/DAT/ IFRQ,MAXD DIMENSION ORBP( 7) , COEF(30) , DOPP(50) , TIME(50) , KDOP(50) REDG 34 DIMENSION GXYZ( 3) , EXPT(99) , A(3,2) , B(3,3,3) , MESS( 3) REDG 35 EQUIVALENCE (LINE(3),LINE3(1)) EQUIVALENCE (ISLS,HSLS),(LINE(2),HHDR) DATA LBLK/4H / DATA IBLK/8H /,TIMT/0./ + , DMAX / 2.48E6 / , DMIN / 1.36E6 / , SCAL / -.10909091 / REDG 40 + , MINL/10/, RADX/4.E-6/,SECD/0./ + , MOD3 / 2048 / , MOD4 / 4096 / , STOM / .016666667 / REDG 42 + , IHOR / 0 / REDG 43 DATA MASI/2H**/,MASS/2H/// C REDG 44 10 I = 1 REDG 45 ISWT = 1 REDG 46 NDOP = NDPI REDG 47 C REDG 48 20 READ(INPT,5,END=90)LINE,ISLS JUL80006 CALL CORE(BUFFER,40) JUL80007 WRITE(10,5)LINE JUL80008 IF (LINE(1).EQ.IBLK) GO TO 20 REDG 51 IF(LINE(2).EQ.IBLK) GO TO 20 CALL CORE(BUFFER,40) JUL80009 IF(ISLS.EQ.IBLK) READ(10,15) IFIT,IY,IDAY,ISAT IF(ISLS.NE.IBLK) READ(10,17) IFIT,IY,IDAY,ISAT IF(IDAY.NE.0) GO TO 50 DO 55 I=1,10 READ(INPT,5) LINE,ISLS 55 CONTINUE GO TO 80 50 CONTINUE ISAT = INTA(ISAT - 57) REDG 54 C IFIT AGENCY IFIFIT= 8 DENOTES PREDICTS SYNCHRONISATION C FOR GEOS-3 AND CMA725 DSCLE=1.000000D0 DELFT=0.D0 SCAL=-.1090909D0 IF(ISAT.NE.75) GO TO 29 DSCLE=1.000000D0/.81 SCAL=-1.000000D0/.81/9. DELFT=720000.D0 29 CONTINUE IHDR=HHDR NPSI = NPSI + 1 REDG 55 IF(LINE3(2).NE.LBLK) GO TO 40 IF (IFLG.EQ.1) GO TO 10 REDG 57 ISAT = NSAT REDG 58 GO TO 60 REDG 59 C REDG 60 30 IMIN=IMIN+DINT(SECD+SECD) JUL80012 LOKG = MINUT (IDAY , IHOR , IMIN) REDG 62 TTAU = SECD REDG 63 ISWT=2 IF (TTAU.GT.(.5)) TTAU = TTAU - 1. REDG 65 IMD=MOD(IMIN,2) TTAU=TTAU+IMD LOKG=LOKG-IMD C REDG 66 40 SECP = SECD REDG 67 LINE(2) = IBLK REDG 68 READ(INPT,5,END=110)LINE JUL80013 CALL CORE(BUFFER,40) JUL 80 WRITE(10,5)LINE 100 IF(LINE(2).EQ.IBLK) GO TO (10,80),ISWT C REDG 72 60 CALL CORE(BUFFER,40) JUL80014 CALL CORE(BUFFER,40) READ(10,25)TDRY,PRES,VPAR,ISLS JUL80015 ISLS=LINE(3) IF(HSLS.EQ.MASS.OR.HSLS.EQ.MASI) GO TO (10,79),ISWT IHDT=HHDR IF(IHDT.NE.IHDR) GO TO 82 C LINE IS A HEADR START A NEW PASS + BACKSPACE HEADR BACKSPACE INPT GO TO 80 82 CONTINUE C REDG 75 ITIM = IHOR REDG 76 CALL CORE(BUFFER,40) JUL80016 READ(10,35)IHOR,IMIN,TIMM,IFRC,IDOP,IREF JUL80017 CALL OCTAL(IFRC,IDOP,IREF) IF (IHOR.LT.ITIM.AND.ISWT.GT.1) IDAY = IDAY + 1 REDG 78 SECD= (DFLOAT(IFRC)*RADX +TIMM) *STOM JUL80018 TIMP = TIMT REDG 80 TIMT=DFLOAT(MINUT(IDAY,IHOR,IMIN)) JUL80019 IF(ISWT.EQ.1) GO TO 30 C REDG 83 70 IF (IREF.GT.MOD3) IREF = IREF - MOD4 REDG 84 IF(IREF.GT.MOD3) IREF=0 DOPT=DFLOAT(IDOP)+DFLOAT(IREF)*SCAL JUL80020 JSLS=1 TIMM = TIMT - TIMP + SECD - SECP REDG 87 C CHECK FOR REASONABLE DELTA T IF(TIMM.GT.5.) TIMM=.1 IF(TIMM.LE.1.E-09) GO TO 40 DOPT=DFLOAT(IDOP)*DSCLE+DFLOAT(IREF)*SCAL+DELFT*TIMM TDOP=DOPT/TIMM TDOP = DOPT / TIMM REDG 88 C REDG 89 IF(DMAX.LT.TDOP.OR.DMIN.GT.TDOP.OR.LINE3(2).EQ.LBLK) JSLS=0 DOPP(I)=DOPT*DFLOAT(JSLS) IONOS=DFLOAT(IREF)*SCAL*10.00000*DFLOAT(JSLS) DOPP(I)=DOPP(I)+DFLOAT(IONOS)*1.000000E07 TIME(I) = TIMM REDG 92 KDOP(I)=JSLS I = I + 1 REDG 94 NDPI = NDPI + 1 REDG 95 NDPA=NDPA+JSLS GO TO 40 REDG 97 79 CALL CORE(BUFFER,40) READ(10,25)TDRY,PRES,VPAR,IFRQ C REDG 98 80 NDOP = NDPI - NDOP REDG 99 IF (NDOP.LT.MINL) GO TO 10 REDG 100 IF (NDOP.GT.MAXD) NDOP = MAXD REDG 101 IF (PRES.LT.500.) PRES = PRES + 1000. REDG 102 IF(ISAT.NE.NSAT) GO TO 10 90 RETURN REDG 103 110 ISWT=3 JUL80023 RETURN C REDG 104 5 FORMAT(3A8,A4) JUL80022 15 FORMAT(1X,2I1,I3,I2) 17 FORMAT(2X,2I1,I3,I2) 25 FORMAT(4X,2F3.0,F2.0,I2,1X,A3) 35 FORMAT(2I2,F2.0,I6,I8,I4) C REDG 110 END REDG 111 SUBROUTINE READTR TRAN 2 C TRAN 3 C TRAN 4 C "READTR " - AUTHOR - P.G. LAWNIKANIS TRAN 5 C - WRITTEN ON - FEBRUARY /75. TRAN 6 C - LAST COMPILED - NOVEMBER /75. TRAN 7 C - REFERENCES - TRANET OPERATIONS MANUAL(APL) TRAN 8 C TRAN 9 C VARIABLES USED -NDOP ,NPSI ,LOKG ,DTAU TRAN 10 C NDPI ,DOPP ,NTIM ,NDPA TRAN 11 C NSAT TRAN 12 C TRAN 13 C VARIABLES ALTERED -ISWT ,DTAU ,FREQ ,NDOP TRAN 14 C ISTN ,ISAT ,DOPP ,LOKG TRAN 15 C NPSI ,NTIM ,TTAU ,ALOK TRAN 16 C NDPI ,KDOP ,TIME ,TAUT TRAN 17 C NDPA ,PRES ,TDRY ,VPAR TRAN 18 C TRAN 19 C VARIABLES RETURNED -*NONE* , , , TRAN 20 C TRAN 21 C EXTERNAL ROUTINES -MODULO ,MINUT , , TRAN 22 C EOF ,(DECODE), , TRAN 23 C TRAN 24 C I/O DEVICES -INPT , , , TRAN 25 C TRAN 26 C TRAN 27 C ›READTR› READS AND DECODES TRANET DATA. TRAN 28 C TRAN 29 IMPLICIT REAL*8(A-H,O-Z) JUL80001 REAL*8 NAME REAL*8 MESS REAL*8 IENE,IEND,ISRC,ISTN REAL*8 LINE(3) JUL80002 COMMON NAME , ISRC , ISAT , INJC , LOKR , LENG , FSAT , NSTN TRAN 30 + , ORBP , IFIT , COEF , NDOP , ISTN , PRES , TDRY , VPAR TRAN 31 + , DOPP , TIME , NTIM , NSAT , NORD , ISWT , LOKG , KDOP TRAN 32 + , NPSI , NPSA , NDPI , NDPA , IRCV TRAN 33 COMMON /DEV/ IEPH , INPT , IOUT , IRED , IPRT TRAN 34 COMMON /TIM/ A , B , ALOK , DTAU , EXPT , GXYZ , IORD TRAN 35 + , MESS , SIGS , TTAU , VPVP , FREQ , TAUT TRAN 36 COMMON/DAT/ IFRC,MAXD DIMENSION ORBP( 7) , COEF(30) , DOPP(50) , TIME(50) , KDOP(50) TRAN 37 + , GXYZ( 3) , EXPT(99) , A ( 6) , B (27) , MESS( 3) TRAN 38 C TRAN 40 DIMENSION TAUT(10),SCAL(10),BUFFER(5) JUL80003 DATA IEND/8H** /,IENE/8H// /,STOM/.016666667/ + , SECP/0./,TIMD/0./,MODE/1/ DATA SCAL / 3.49090909091 , 3.49090909091 , 1.16363636364 TRAN 44 + , 1.64609053498 , 0. , 1.16363636364 , 4*0. / TRAN 45 C TRAN 46 10 ISWT = 1 TRAN 47 ISWU = 0 TRAN 48 C TRAN 49 20 ISWU = ISWU + 1 TRAN 50 C TRAN 51 30 READ(INPT,5,END=90)LINE,IYER,IDAY,IHOR,IMIN,ICOD,DTAU JUL80004 + , FREQ , NDOP TRAN 53 CALL CORE(BUFFER,40) JUL80005 WRITE(10,5)LINE JUL80006 IF(LINE(1).EQ.IENE) LINE(1)=IEND JUL80009 IF(LINE(1).NE.IEND) GO TO (40,30,30,30),ISWU JUL80009 GO TO (60 , 60 , 20 , 10) , ISWU TRAN 57 C TRAN 58 40 ISWU = 2 TRAN 59 CALL CORE(BUFFER,40) JUL80007 READ(10,15)ISTN,I,ISAT JUL80008 C CHECK FOR GEOS-3 IF(ISAT.EQ.17) ISAT=75 IF(I.EQ.1) I=30 IF(I.NE.30.OR.ICOD.GT.351) GO TO 20 FEB76 4 IF(NSAT.NE.0.AND.ISAT.NE.NSAT) GO TO 20 FEB76 5 IFRC=0 C TRAN 62 IF (ICOD.EQ.351) ICOD = 269 TRAN 63 ICOD=MOD(ICOD-261,5)+1 JUL80010 DOP=DFLOAT(2**NDOP)*SCAL(ICOD) ICDD=ICOD LOKG = IDAY * 1440 TRAN 66 NPSI = NPSI + 1 TRAN 67 NDOP = 0 TRAN 68 NTIM = 0 TRAN 69 TIMO=DFLOAT(IDINT(DFLOAT(MINUT(0,IHOR,IMIN))*6.E-3))/6.E-3 JUL80011 GO TO 30 TRAN 71 C TRAN 72 42 ISWT = 3 TRAN 73 ISWU = 1 TRAN 74 DTAU=DFLOAT(IDINT(TIMD)) JUL80012 LOKG=LOKG+IDINT(TIMD) JUL80013 TTAU = SECD TRAN 77 ALOK = TIMD - DTAU TRAN 78 C TRAN 79 50 SECP = SECD TRAN 80 C TRAN 81 60 READ(INPT,5,END=90)LINE JUL80014 CALL CORE(BUFFER,40) JUL80015 WRITE(10,5)LINE JUL80016 IF(LINE(1).EQ.IEND) GO TO 80 JJUL 80 CALL CORE(BUFFER,40) JUL80017 READ(10,25)TIMA,TIMB,TIMC N JUL80018 SECD = TIMC * STOM TRAN 86 TIMB = TIMB * STOM TRAN 87 IF (TIMA.EQ.9.) GO TO (70 , 68) , ISWU TRAN 88 TIMO= TIMA/ .60000000000E-02 AUG76 1 TIMP = TIMD TRAN 89 TIMD= TIMO + TIMB AUG76 2 GO TO (62 , 42) , ISWU TRAN 91 C TRAN 92 62 NDOP = NDOP + 1 TRAN 93 IF (NDOP.GT.MAXS) GO TO 50 TRAN 94 NDPI = NDPI + 1 TRAN 95 DOPP(NDOP)=DOP KDOP(NDOP) = 1 TRAN 97 TIME(NDOP) = SECD - SECP + TIMD - TIMP TRAN 98 C CHECK FOR REASONABLE DELTA T IF(TIME(NDOP).GT.5.) TIME(NDOP)=.1 IF(ICOD.EQ.4) DOPP(NDOP)=DOPP(NDOP)+TIME(NDOP)*7.2000000E05 GO TO 50 TRAN 99 C TRAN 100 68 DTAU = TIMO + TIMB TRAN 101 C TRAN 102 70 NTIM = NTIM + 1 TRAN 103 TAUT(NTIM) = TIMO + TIMB - DTAU + SECD - TOFF TRAN 104 GO TO 60 TRAN 105 C TRAN 106 80 IF (NDOP.EQ.0) GO TO 10 TRAN 107 ISWT = 2 TRAN 108 IF (NDOP.GT.MAXD) NDOP = MAXD TRAN 109 NDPA= NDPA + NDOP TRAN 110 C *** UNTIL ›METDAT› MADE COMPATIBLE *** C TRAN 111 PRES = 1014. TRAN 112 TDRY = 15. TRAN 113 VPAR = 58.5 TRAN 114 90 RETURN JUL80019 C TRAN 116 5 FORMAT(A4,A4,A3,A2,1X,I3,1X,2I2,1X,I3,1X,A4,1X,F5.0,7X,I2) JUL80020 15 FORMAT (1X,A3,6X,2I2) TRAN 118 25 FORMAT (F1.0,F4.0,5X,F6.6) TRAN 119 END TRAN 120 SUBROUTINE READEF REDF 2 C REDF 3 C REDF 4 C "READEF " - AUTHOR - P.G. LAWNIKANIS REDF 5 C - WRITTEN ON - DECEMBER /74. REDF 6 C - LAST COMPILED - APRIL 1975. REDF 7 C - REFERENCES - *NONE* REDF 8 C REDF 9 C VARIABLES USED -IEPO ,IEPH ,NORD ,ISWT REDF 10 C REDF 11 C VARIABLES ALTERED -LOKR ,LENG ,COEF ,INJC REDF 12 C FSAT ,ORBP ,IFIT ,ISWT REDF 13 C REDF 14 C VARIABLES RETURNED -*NONE* , , , REDF 15 C REDF 16 C EXTERNAL ROUTINES -EOF ,INT , , REDF 17 C REDF 18 C I/O DEVICES -IEPH , , , REDF 19 C REDF 20 C REDF 21 IMPLICIT REAL*8(A-H,O-Z) JUL80001 REAL*8 NAME REAL*8 ISRC,ISTN COMMON NAME , ISRC , ISAT , INJC , LOKR , LENG , FSAT , NSTN REDF 22 + , ORBP , IFIT , COEF , NDOP , ISTN , PRES , TDRY , VPAR REDF 23 + , DOPP , TIME , IFLG , NSAT , NORD , ISWT , LOKG , KDOP REDF 24 + , NPSI , NPSA , NDPI , NDPA REDF 25 INTEGER EOF JUL80003 DIMENSION ORBP( 7) , COEF(30) , DOPP(50) , TIME(50) , KDOP(50) REDF 26 COMMON /DEV/ IEPH , INPT , IOUT , IRED , IPRT REDF 27 COMMON /PAR/ DAYP , TPER , XMOT , APTP , DATP , ECCT , RAAN REDF 28 + , DRAN , RAGR , ANGL , JSAT , IEPO REDF 29 C REDF 32 EOF=0 JUL80004 GO TO (10 , 20) , IEPO REDF 33 C REDF 34 10 READ(IEPH,END=40)LOKR,LENG,(COEF(I),I=1,NORD),INJC,FSAT JUL80005 + , ORBP , IFIT REDF 36 GO TO 30 REDF 37 40 EOF=1 JUL80006 C REDF 38 20 READ(IEPH,END=50)LOKR,LENG,(COEF(I),I=1,NORD) JUL80007 C REDF 40 30 IF(EOF.NE.0)ISWT=ISWT+3 GO TO 60 50 EOF=1 JUL80008 GO TO 30 JUL80009 60 RETURN C REDF 43 END REDF 44 SUBROUTINE WRITE5 RIT5 2 C RIT5 3 C RIT5 4 C "WRITE5 " - AUTHOR - P.G. LAWNIKANIS RIT5 5 C - WRITTEN ON - DECEMBER /74. RIT5 6 C - LAST COMPILED - NOVEMBER /75. RIT5 7 C - REFERENCES - J.KOUBA .. PROGRAM GEODOP. RIT5 8 C RIT5 9 C VARIABLES USED -IEPO ,TTAU ,TPER ,PERD RIT5 10 C APTP ,DATP ,RAAN ,DRAN RIT5 11 C RAGR ,TDRY ,VPAR ,NAME RIT5 12 C ISRC ,ISAT ,INJC ,LOKR RIT5 13 C LENG ,FSAT ,NSTN ,ORBP RIT5 14 C IFIT ,COEF ,NORD ,NDOP RIT5 15 C ISTN ,ALOK ,PRES ,FREQ RIT5 16 C DOPP ,TIME RIT5 17 C RIT5 18 C VARIABLES ALTERED -ORBP ,VPAR , , RIT5 19 C RIT5 20 C VARIABLES RETURNED -*NONE* , , , RIT5 21 C RIT5 22 C EXTERNAL ROUTINES -TIMIN ,VPSAT , , RIT5 23 C FLOAT ,INT , , RIT5 24 C RIT5 25 C I/O DEVICES -IOUT , , , RIT5 26 C RIT5 27 C RIT5 28 IMPLICIT REAL*8(A-H,O-Z) JUL80001 REAL*8 NAME REAL*8 MESS REAL*8 ISRC,ISTN COMMON NAME , ISRC , ISAT , INJC , LOKR , LENG , FSAT , NSTN RIT5 29 + , ORBP , IFIT , COEF , NDOP , ISTN , PRES , TDRY , VPAR RIT5 30 + , DOPP , TIME , NTIM , NSAT , NORD , ISWT , LOKG , KDOP RIT5 31 + , NPSI , NPSA , NDPI , NDPA , IRCV RIT5 32 DIMENSION ORBP( 7) , COEF(30) , DOPP(50) , TIME(50) , KDOP(50) RIT5 33 COMMON /DEV/ IEPH , INPT , IOUT , IRED , IPRT RIT5 34 COMMON /PAR/ DAYP , TPER , XMOT , APTP , DATP , ECCT , RAAN RIT5 35 + , DRAN , RAGR , ANGL , JSAT , IEPO , PERD RIT5 36 COMMON /TIM/ A , B , ALOK , DTAU , EXPT , GXYZ , IORD RIT5 37 + , MESS , SIGS , TTAU , VPVP , FREQ , TAUT RIT5 38 DIMENSION GXYZ( 3) , EXPT(99) , A(3,2) , B(3,3,3) , MESS( 3) RIT5 39 + , TAUT(10) RIT5 40 DATA IZER / 0 / , WEAR / .0043752695 / , PITW / 6.28318531 / RIT5 43 + , J / 0 / RIT5 44 C RIT5 45 I = NPSA RIT5 46 CALL TIMIN RIT5 47 IF (I.EQ.NPSA) RETURN RIT5 48 GO TO (20 , 10) , IEPO RIT5 49 C RIT5 50 10 DTIM=DFLOAT(LOKG)-TPER JUL80003 DTIN=DFLOAT(IDINT(DTIM/PERD))*PERD JUL80004 ORBP(1) = DTIM - DTIN RIT5 53 ORBP(4) = APTP - DATP * DTIM RIT5 54 ORBP(5) = RAAN + DRAN * DTIM RIT5 55 DTIM = RAGR + WEAR * DTIN RIT5 56 ORBP(6)=DTIM-DFLOAT(IDINT(DTIM/PITW))*PITW JUL80005 C RIT5 58 20 VPAR = VPSAT(TDRY) * VPAR * .01 RIT5 59 WRITE (IOUT) NAME , ISRC , ISAT , INJC , LOKR , LENG , FSAT RIT5 60 + , NSTN , ORBP , IFIT , (COEF(I),I=1,NORD) , NDOP RIT5 61 WRITE (IOUT) ISTN , ALOK , PRES , TDRY , VPAR , IZER RIT5 62 + , FREQ , NDOP , (DOPP(I),I=1,NDOP) RIT5 63 + , (TIME(I),I=1,NDOP) RIT5 64 RETURN RIT5 65 C RIT5 66 END RIT5 67 SUBROUTINE TIMII TIMF 2 C TIMF 3 C TIMF 4 C "TIMII " - AUTHOR - P.G. LAWNIKANIS TIMF 5 C - WRITTEN ON - JANUARY /75. TIMF 6 C - LAST COMPILED - NOVEMBER /75. TIMF 7 C - REFERENCES - *NONE* TIMF 8 C TIMF 9 C VARIABLES USED -IRCV ,EXPT TIMF 10 C TIMF 11 C VARIABLES ALTERED -A ,B , , TIMF 12 C TIMF 13 C VARIABLES RETURNED -*NONE* , , , TIMF 14 C TIMF 15 C EXTERNAL ROUTINES -*NONE* , , , TIMF 16 C TIMF 17 C I/O DEVICES -IRED TIMF 18 C TIMF 19 C TIMF 20 IMPLICIT REAL*8(A-H,O-Z) JUL80001 REAL*8 NAME REAL*8 MESS REAL*8 ISRC,ISTN REAL*8 IBLK,IRJT,IRJU,IRJV COMMON NAME , ISRC , ISAT , INJC , LOKR , LENG , FSAT , NSTN TIMF 21 + , ORBP , IFIT , COEF , NDOP , ISTN , PRES , TDRY , VPAR TIMF 22 + , DOPP , TIME , NTIM , NSAT , NORD , ISWT , LOKG , KDOP TIMF 23 + , NPSI , NPSA , NDPI , NDPA , IRCV TIMF 24 COMMON /DEV/ IEPH , INPT , IOUT , IRED , IPRT TIMF 25 COMMON /TIM/ A , B , ALOK , DTAU , EXPT , GXYZ , IORD TIMF 26 + , MESS , SIGS , TTAU , VPVP , FREQ , TAUT TIMF 27 COMMON/DAT/ IFRC,MAXD DIMENSION C(6) DIMENSION ORBP( 7) , COEF(30) , DOPP(50) , TIME(50) , KDOP(50) TIMF 28 DIMENSION GXYZ( 3) , EXPT(99) , A(3,2) , B(3,3,3) , MESS( 3) TIMF 29 + , A1( 3) , A2( 3) , B1(3,3) , B2(3,3) , B3(3,3) TIMF 30 DIMENSION APRI(3,2), LDOP(10) , TAUT(10) , V( 3) TIMF 31 DIMENSION IRJCT(50) TIMF 32 EQUIVALENCE (A(1,1),C(1)) EQUIVALENCE (A(1,1),A1(1)), (A(1,2),A2(1)) + , (B(1,1,1),B1(1,1)), (B(1,1,2),B2(1,1)) + , (B(1,1,3),B3(1,1)) DATA APRI / 4.4444444E-07 , 1.7777777E-04 , 2.7777777E-04 TIMF 35 + , 4.4444444E-07 , 1.1111111E-01 , 1.1111111E-01 / TIMF 36 + , CREP / 5.5594008E-11 / , DAYS / 6.9444444E-04 / TIMF 37 + ,IBLK/8H /, IRJT/8HRJT @99%/ + , SCHI / 13.4E-03 / , SIZE / 10. / TIMF 39 + , STOM / 1.6666667E-02 / , TMAX / 1.0000000E-05 / TIMF 40 + , XMTM / 6.0000000E+04 / , XNIN / 1.1111111E-01 / TIMF 41 + , XSEC / 4.6296296E+00 / , XTIR / 1.1574074E-08 / TIMF 42 + ,IRJU/8HRJT<1 DF/ + ,IRJV/8HRJT>3SIG/,TONE/5.0000000E-04/ + , S0SQ /1.111E-03/, TERR/1.0E-02/ TIMF 45 TMAX=DSQRT(SCHI)/XMTM JUL80002 C TIMF 47 DO 100 I = 1,3 TIMF 48 A(I,1)=EXPT(I+1) A(I,2)=EXPT(I+5) DO 200 K = 1,2 TIMF 50 DO 200 J = 1,3 TIMF 51 B(I,J,K) = 0. TIMF 52 200 CONTINUE TIMF 53 B(I,I,2) = APRI(I,IRCV) TIMF 54 100 CONTINUE TIMF 55 C TIMF 56 VPVP=0.0 FIRT=EXPT(1) FIRT2=EXPT(5) RETURN TIMF 58 C TIMF 59 ENTRY TIMIN TIMF 60 C TIMF 61 C TIMF 62 C "TIMIN " - AUTHOR - P.G. LAWNIKANIS TIMF 63 C - COAUTHOR - J. KOUBA TIMF 64 C - WRITTEN ON - JANUARY /75. TIMF 65 C - LAST COMPILED - NOVEMBER /75. TIMF 66 C - REFERENCES - *NONE* TIMF 67 C TIMF 68 C VARIABLES USED -LOKG ,LENG ,LOKR ,NPSA TIMF 69 C IRCV ,NDOP ,TTAU ,COEF TIMF 70 C GXYZ ,IORD ,TIME ,TAUT TIMF 71 C DTAU ,SIGS ,ALOK ,NTIM TIMF 72 C A ,B ,VPVP TIMF 73 C TIMF 74 C VARIABLES ALTERED -SIGS ,ALOK ,A ,TAUT TIMF 75 C TTAU ,DTAU ,DOPP ,KDOP TIMF 76 C MESS ,B ,NPSA ,EXPT TIMF 77 C VPVP , , , TIMF 78 C TIMF 79 C VARIABLES RETURNED -*NONE* , , , TIMF 80 C TIMF 81 C EXTERNAL ROUTINES -SLAN ,TRINN ,MULTP , TIMF 82 C ABS ,INT ,FLOAT ,SQRT TIMF 83 C TIMF 84 C I/O DEVICES -*NONE* , , , TIMF 85 C TIMF 86 C TIMF 87 SIGS = 0. TIMF 88 TIML=DFLOAT(LOKG) JUL80003 TIMM = 0. TIMF 90 TIMN = 0. TIMF 91 VPV=0. VPVP=0. TIMO=2./(DFLOAT(LENG)-1.) JUL80004 TIMP=TIML-DFLOAT(LOKR) JUL80005 IF(FIRT.LE.1.E-6.AND.NPSA.EQ.0) FIRT=TIML*DAYS IF(FIRT2.LE.1.E-06) GO TO 7 C REST TIME AS PER 2ND INPUT CURVE C MAX. TWO INPUT TIME CURVES ALLOWED FIRT=FIRT2 DO 8 I=1,3 8 A(I,1)=A(I,2) 7 CONTINUE GO TO (2 , 4) , IRCV TIMF 95 C TIMF 96 2 CONTINUE TIMF 97 NTIM=0 ALOK=SLAN(COEF,GXYZ,IORD,TIMO,TIMP,TTAU) + TTAU J = 0 TIMF 99 K = NDOP + 1 TIMF 100 IF(IFRC.EQ.2) GO TO 12 DO 300 I = 1,K TIMF 101 IRJCT(I)= 0 TIMF 102 L=IDINT(TTAU+TTAU+STOM) IF ((L - L / 4 * 4).NE.0) GO TO 300 TIMF 104 TIMQ=DFLOAT(L/2) JUL80006 TIMR = SLAN (COEF , GXYZ , IORD , TIMO , TIMP , TIMQ) TIMF 106 TEMP = TTAU - TIMQ + TIMR TIMF 107 IF (I.EQ.1) ALOK = TEMP TIMF 108 10 J = J + 1 TIMF 109 LDOP(J) = I TIMF 110 TAUT(J) = TEMP TIMF 111 TIMM = TIMM + TEMP TIMF 112 TIMN = TIMN + 1. TIMF 113 300 TTAU = TTAU + TIME(I) TIMF 114 C TIMF 115 GO TO 12 TIMF 116 C TIMF 117 4 ALOK = ALOK +SLAN(COEF , GXYZ , IORD , TIMO , TIMP , TTAU) + TTAUTIMF 118 NPSA = NPSA + 1 TIMF 119 IF(NTIM.GE.1) GO TO 6 ALOK=ALOK+TIML DTAU=0. RETURN 6 CONTINUE J=0 AUG76 3 DO 400 I = 1,NTIM TIMF 121 TIMQ = TAUT(I) TIMF 122 TIMR = SLAN (COEF , GXYZ , IORD , TIMO , TIMP , TIMQ) TIMF 123 TEMP=TIMQ-DFLOAT(IDINT(TIMQ+STOM))+TIMR C REJECT IF TEMP.GE. 1 SECOND AUG76 4 IF(DABS(TEMP).GE.STOM) GO TO 400 JUL80007 TIMM = TIMM + TEMP TIMF 125 J= J +1 AUG76 6 TAUT(J)= TEMP AUG76 7 400 CONTINUE AUG76 8 NTIM= J AUG76 9 TIMN=DFLOAT(NTIM) JUL80008 C TIMF 129 12 CONTINUE TIMF 130 ALOK = ALOK + TIML TIMF 131 DTAU=(TIML+8)*DAYS-FIRT C CHECK FOR YEARS END IF(DTAU.LE.-200.) DTAU=DTAU+365. DT=(C(1)+(C(2)+C(3)*DTAU)*DTAU)/XMTM DTAV=DT IF(IFRC.EQ.2) GO T O 18 TIMMR= 0 TIMF 134 TIMPR= 0 TIMF 135 VPV= 0 TIMF 136 C INITALIZED REJECT VECTOR TIMF 137 C TIMF 138 DO 500 I = 1,J TIMF 139 XMIS= TAUT(I) - DT TIMF 140 IF(DABS(XMIS).LE.TONE) GO TO 500 JUL80009 TIMPR= TIMPR +1 TIMF 142 TIMMR= TIMMR + TAUT(I) TIMF 143 VPV= VPV+ XMIS*XMIS TIMF 144 IRJCT(I)= LDOP(I) TIMF 145 500 SIGS = SIGS + XMIS * XMIS TIMF 146 IF(TIMPR.EQ.0.0) GO TO 1103 IF(TIMPR.LE.1.0) GO TO 1101 IF ((TIMN - TIMPR).GT.1.) GO TO 1101 TIMF 149 REAM= TIMMR/ TIMPR TIMF 150 REAN= REAM - DT TIMF 151 SIGM=DSQRT((VPV-TIMPR*REAN*REAN)/TIMPR/(TIMPR-1)) C TMXX MA X LIMIT COMPATIBLE WITH CHISQR ( NOT CHISQR LIMIT) TIMF 153 TMXX=TMAX*3./DSQRT(TIMPR) JUL 80 IF(SIGM.GT.TMXX) GO TO 1101 TIMF 155 C ALL REJECTS ARE CONSISTENT TIMF 156 C(1)=REAM*XMTM-(C(2)+C(3)*DTAU)*DTAU DT= REAM TIMF 158 DO 1102 I=1,3 TIMF 159 B(I,1,2)= 0. TIMF 160 1102 B(1,I,2)= 0. TIMF 161 B(1,1,2)= 4.44E -07 TIMF 162 SIGS= SIGM TIMF 163 DTAU= REAM* XMTM TIMF 164 DTAV= REAM TIMF 165 TEMP= 0. TIMF 166 GO TO 18 TIMF 167 1101 CONTINUE TIMF 168 C REJECTS NOT CONSISTENT TIMF 169 SIGS= SIGS- VPV TIMF 170 TIMM= TIMM- TIMMR TIMF 171 TIMN= TIMN- TIMPR TIMF 172 IF(IRCV.EQ.2) GO TO 1103 TIMF 173 DO 1104 I=1,J TIMF 174 IF(IRJCT(I).EQ.0) GO TO 1104 TIMF 175 K= IRJCT(I) TIMF 176 DOPP(K ) = 0. TIMF 177 KDOP(K ) = 0 TIMF 178 NDPA= NDPA -1 TIMF 179 IF(K.EQ.1) GO TO 1104 TIMF 180 DOPP(K-1)= 0. TIMF 181 KDOP(K-1)= 0. TIMF 182 NDPA= NDPA-1 TIMF 183 1104 CONTINUE TIMF 184 1103 CONTINUE TIMF 185 C TIMF 186 NTIM=IDINT(TIMN) IF (TIMN.GT.0.) GO TO 16 TIMF 188 IF (IRCV.EQ.1) MESS(1) = IRJU TIMF 189 RETURN TIMF 190 C TIMF 191 16 CONTINUE TIMF 192 DTAV = TIMM / TIMN TIMF 193 TEMP= DTAV - DT TIMF 194 IF(TIMN.GT.1.)SIGS=DSQRT((SIGS-TEMP*TEMP*TIMN)/(TIMN-1.)/TIMN) DTAU = DTAV * XMTM TIMF 196 C TIMF 197 TMXX=TMAX*3./DSQRT(TIMN) JUL80010 IF(SIGS.LE.TMXX) GO TO 18 TIMF 199 IF (IRCV.EQ.1) MESS(1) = IRJV TIMF 200 RETURN TIMF 201 C TIMF 202 18 CONTINUE TIMF 203 IF (IRCV.EQ.1) ALOK = ALOK - DTAV TIMF 204 IF(IFRC.NE.2) GO TO 902 DTAU=DTAV*XMTM C SKIP THE REST FOR IFRC=2 I.E. FOR 324/162 FREQ PAIR GO TO 901 902 CONTINUE SIGS = SIGS * XMTM TIMF 205 TEMP= TIMN* XNIN TIMF 206 TIMM=TIML*DAYS-FIRT TIMN = TIMM * TIMM TIMF 208 TIMO = TIMM * TEMP TIMF 209 TIMP = TIMM * TIMO TIMF 210 TIMQ = TIMM * TIMP TIMF 211 TIMR = TIMM * TIMQ TIMF 212 XMIS = DTAU - (A1(1) + A1(2) * TIMM + A1(3) * TIMN) TIMF 213 DO 700 I = 1,3 TIMF 214 MESS(I) = IBLK TIMF 215 DO 700 J = 1,3 TIMF 216 B1(I,J) = B2(I,J) TIMF 217 700 CONTINUE TIMF 218 C TIMF 219 B(1,1,1) = B(1,1,1) + TEMP TIMF 220 B(1,2,1) = B(1,2,1) + TIMO TIMF 221 B(1,3,1) = B(1,3,1) + TIMP TIMF 222 B(2,1,1) = B(1,2,1) TIMF 223 B(2,2,1) = B(2,2,1) + TIMP TIMF 224 B(2,3,1) = B(2,3,1) + TIMQ TIMF 225 B(3,1,1) = B(1,3,1) TIMF 226 B(3,2,1) = B(2,3,1) TIMF 227 B(3,3,1) = B(3,3,1) + TIMR TIMF 228 V( 1) = TEMP * XMIS TIMF 229 V( 2) = TIMO * XMIS TIMF 230 V( 3) = TIMP * XMIS TIMF 231 DO 800 I = 1,3 TIMF 232 DO 800 J = 1,3 TIMF 233 B3(I,J) = B1(I,J) TIMF 234 800 CONTINUE TIMF 235 C TIMF 236 CALL CHOLD(B1,3,3,DETA,JCHK) DO 1112 I=1,3 TIMF 238 DO 1112 J=I,3 TIMF 239 1112 B1(J,I)= B1(I,J) TIMF 240 CALL MULTP ( 3 , 3 , 1 , 3 , 3 , B1 , V , A2) TIMF 241 TEMP = -XMIS * (A2(1) + A2(2) * TIMM + A2(3) * TIMN - XMIS) TIMF 242 TONE=DSQRT(((((B1(3,3)*TIMM+B1(2,3)+B1(3,2))*TIMM JUL80011 + + B1(1,3) + B1(2,2) + B1(3,1)) * TIMM TIMF 244 + + B1(1,2) + B1(2,1)) * TIMM TIMF 245 + + B1(1,1)) * S0SQ + TERR) / XMTM * 3. TIMF 246 IF (TEMP.LE.SCHI) GO TO 20 TIMF 247 MESS(1) = IRJT TIMF 248 C TIMF 249 20 CONTINUE TIMF 250 IF (IRCV.EQ.1) NPSA = NPSA + 1 TIMF 251 IF (NPSA.LE.99) EXPT(NPSA) = DTAU TIMF 252 VPVP = VPVP + TEMP TIMF 253 DO 900 I = 1,3 TIMF 254 A1(I) = A1(I) + A2(I) TIMF 255 DO 900 J = 1,3 TIMF 256 B2(I,J) = B3(I,J) TIMF 257 900 CONTINUE TIMF 258 901 CONTINUE IF(IRCV.EQ.1) NPSA=NPSA+1 IF(NPSA.LE.99) EXPT(NPSA)=DTAU VPVP=VPVP+TEMP RETURN TIMF 259 C TIMF 260 ENTRY TIMIP TIMF 261 C TIMF 262 C TIMF 263 C "TIMIP " - AUTHOR - P.G. LAWNIKANIS TIMF 264 C - WRITTEN ON - JANUARY /75. TIMF 265 C - LAST COMPILED - NOVEMBER /75. TIMF 266 C - REFERENCES - *NONE* TIMF 267 C TIMF 268 C VARIABLES USED -VPVP ,NPSA ,B ,A TIMF 269 C EXPT TIMF 270 C TIMF 271 C VARIABLES ALTERED -B , , , TIMF 272 C TIMF 273 C VARIABLES RETURNED -*NONE* , , , TIMF 274 C TIMF 275 C EXTERNAL ROUTINES -PRINTP , , , TIMF 276 C FLOAT ,INT ,SQRT , TIMF 277 C TIMF 278 C I/O DEVICES -IPRT , , , TIMF 279 C TIMF 280 C TIMF 281 TEMP = VPVP TIMF 282 IF(NPSA.GT.3) TEMP=TEMP/DFLOAT(NPSA-3) DO 1000 I = 1,3 TIMF 284 DO 1000 J = 1,3 TIMF 285 B1(I,J) = B1(I,J) * TEMP TIMF 286 1000 CONTINUE TIMF 287 TIMM = A1( 2) * XSEC TIMF 288 TIMN=DSQRT(B1(2,2))*XSEC JUL80013 TIMO = A1( 3) * XTIR TIMF 290 TIMP=DSQRT(B1(3,3))*XTIR JUO80014 WRITE (IPRT, 5) ((B1(I,J),J=1,3),I=1,3) , TEMP , A1(1) TIMF 292 + , A1(2) , TIMM , TIMN , A1(3) , TIMO , TIMP TIMF 293 C TIMF 294 J = NPSA TIMF 295 IF (J.GT.99) J = 99 TIMF 296 TEMP=DFLOAT(IDINT(EXPT(J))) TIMM = TEMP - 1. TIMF 298 TIMN = TEMP + 1. TIMF 299 IF(TEMP.GE.EXPT(1)) TIMM=TIMM-SIZE IF(TEMP.LE.EXPT(1)) TIMN=TIMN+SIZE CALL PRINTP(1,1,TIMM,TIMN,1.,ISTN,1.,1) DO 1100 I = 1,J TIMF 303 CALL PRINTP(2,2,2.,2.,EXPT(I),2.,2.,2) 1100 CONTINUE TIMF 305 CALL PRINTP(3,3,3.,3.,3.,3.,3.,3) RETURN TIMF 307 C TIMF 308 5 FORMAT (1H1,//,31H VARIANCE - COVARIANCE MATRIX TIMF 309 + ,3(//,3(5X,E13.6)) TIMF 310 + ,///,23H VARIANCE FACTOR ... ,E13.6 TIMF 311 + ,///,17H PHASE SOLUTION TIMF 312 + ,//,17H INTERCEPT ... ,E13.6 TIMF 313 + ,//,17H SLOPE ....... ,E13.6,16H FREQ.OFF ... TIMF 314 + ,E10.3, 6H SD ,E10.3 TIMF 315 + ,//,17H CURVATURE ... ,E13.6,16H DRIFT ...... TIMF 316 + ,E10.3, 6H SD ,E10.3 )TIMF 317 15 FORMAT (F5.0) TIMF 318 END TIMF 319 FUNCTION SLAN (COEF , CORD , IORD , SCAL , BIAS , TIME) SLAN 2 C SLAN 3 C SLAN 4 C "SLAN " - AUTHOR - P.G. LAWNIKANIS SLAN 5 C - WRITTEN ON - FEBRUARY /75. SLAN 6 C - LAST COMPILED - APRIL 1975. SLAN 7 C - REFERENCES - *NONE* SLAN 8 C SLAN 9 C VARIABLES USED -BIAS ,TIME ,SCAL ,IORD SLAN 10 C COEF ,CORD ,SLAN SLAN 11 C SLAN 12 C VARIABLES ALTERED -SLAN , , , SLAN 13 C SLAN 14 C VARIABLES RETURNED -SLAN , , , SLAN 15 C SLAN 16 C EXTERNAL ROUTINES -CHEBY , , , SLAN 17 C SQRT , , , SLAN 18 C SLAN 19 C I/O DEVICES -*NONE* , , , SLAN 20 C EXTERNAL ROUTINES -*NONE* , , , SLAN 21 C SLAN 22 C SLAN 23 IMPLICIT REAL*8(A-H,O-Z) JUL80001 DIMENSION COEF(IORD,3) , CORD( 3) , CHEB( 10) SLAN 24 DATA CMIN / 1.798755003E10 / SLAN 25 C SLAN 26 SLAN = 0. SLAN 27 TEMP = (BIAS + TIME) * SCAL - 1. SLAN 28 CALL CHEBY (CHEB , CHEB , 0 , IORD , TEMP , TEMP) SLAN 29 DO 100 I = 1,3 SLAN 30 TEMP = COEF(1,I) - CORD(I) SLAN 31 DO 200 J = 2,IORD SLAN 32 TEMP = TEMP + CHEB(J) * COEF(J,I) SLAN 33 200 CONTINUE SLAN 34 SLAN = SLAN + TEMP * TEMP SLAN 35 100 CONTINUE SLAN 36 SLAN=-DSQRT(SLAN)/CMIN JUL80002 RETURN SLAN 38 END SLAN 39 SUBROUTINE OCTAL(IR,ID,IF) CALL BASE(IR,IU) CALL BASE(ID,IG) CALL BASE(IF,IH) IR=IU ID=IG IF=IH RETURN END SUBROUTINE BASE(NUM,IDEC) INTEGER BAS,DECNO,TEMP,B10 BAS=8 B10=10 DECNO=0 DO 20 I=1,20 TEMP=NUM-(NUM/B10)*B10 DECNO=DECNO+TEMP*BAS**(I-1) NUM=NUM/B10 IF(NUM.EQ.0) GO TO 30 20 CONTINUE GO TO 40 30 IDEC=DECNO RETURN 40 STOP END FUNCTION VPSAT(TEMP) C C C 'VPSAT '- AUTHOR - P.G. LAWNIKANIS C - WRITTEN ON - DECEMBER /74 C - LAST COMPILED - APRIL 1975 C REFERENCES - D.E. WELLS .. PROGRAM WEATHER C C VARIABLES USED -TEMP C C VARIABLES ALTERED -VPSAT C C VARIABLES RETURNED -VPSAT C C EXTERNAL ROUTINES -XTOY , EXP C C I/O DEVICES -*NONE* C C C VPSAT RETURNS THE SATURATION VAPOUR-PRESSURE FOR 'TEMP'. C 'TEMP' IN DEGREES CELSIUS / 'VPSAT' IN MILLIBARS. C C IMPLICIT REAL*8(A-H,O-Z) DATA COF1/ 1013.246 / , COF2 / 18.19728 / , COF3 / .0187265 / + , COF4 / -8.03945 / , COF5 / 3.1813E-7 / , COF6 / 26.1205 / + , POWR / 5.02808 / , TKEL / 273.16 / , TKL1 / 373.16 / C TEMK=TEMP + TKEL TEM1 = TKL1 / TEMK TEM2 = TEM1 - 1. TEM3 = 1. - TEMK / TKL1 C VPSAT = COF1 * TEM1 ** POWR / DEXP + (COF2 * TEM2 + + COF3 * (1. - DEXP(COF4 * TEM2)) + + COF5 * (DEXP(COF6 * TEM3) -1.)) RETURN END SUBROUTINE CHOLD(A,IRDA,NA,DETA,*) 0420 C 0430 C MATRIX INVERSION USING CHOLESKI DECOMPOSITION 0440 C 0450 C INPUT ARGUMENTS 0460 C A = ARRAY CONTAINING POSITIVE DEFINITE SYMMETRIC INPUT MATRIX 0470 C IRDA = ROW DIMENSION OF ARRAY CONTAINING INPUT MATRIX 0480 C NA = SIZE OF INPUT MATRIX 0490 C OUTPUT ARGUMENTS 0500 C A = CONTAINS INVERSE OF INPUT MATRIX (INPUT DESTROYED) 0510 C DETA = DETERMINANT OF INPUT MATRIX 0520 C * = ERROR RETURN (TAKEN IF NA .LT. 1 OR IF DETA .LT. SING) 0530 C 0540 DOUBLE PRECISION A,DETA,SUM,SQRT,DSQRT,ABS,DABS,SING 0550 DIMENSION A(IRDA,NA) 0560 SQRT(SUM) = DSQRT(SUM) 0570 ABS(DETA) = DABS(DETA) 0580 DATA SING/1D-10/ 0590 C CHOLESKI DECOMPOSITION OF INPUT MATRIX INTO TRIANGULAR MATRIX 0600 IF(NA .LT. 1) GO TO 18 0610 DETA = A(1,1) 0620 A(1,1) = SQRT(A(1,1)) 0630 IF(NA .EQ. 1) GO TO 6 0640 DO 1 I = 2,NA 0650 1 A(I,1) = A(I,1) / A(1,1) 0660 DO 5 J = 2,NA 0670 SUM = 0. 0680 J1 = J - 1 0690 DO 2 K = 1,J1 0700 2 SUM = SUM + A(J,K) ** 2 0710 DETA = DETA * (A(J,J) - SUM) 0720 A(J,J) = SQRT(A(J,J) - SUM) 0730 IF(J .EQ. NA) GO TO 5 0740 J2 = J + 1 0750 DO 4 I = J2,NA 0760 SUM = 0. 0770 DO 3 K = 1,J1 0780 3 SUM = SUM + A(I,K) * A(J,K) 0790 4 A(I,J) = (A(I,J) - SUM) / A(J,J) 0800 5 CONTINUE 0810 6 IF(ABS(DETA) .LT. SING) GO TO 16 0820 C INVERSION OF LOWER TRIANGULAR MATRIX 0830 DO 7 I = 1,NA 0840 7 A(I,I) = 1. / A(I,I) 0850 IF(NA .EQ. 1) GO TO 10 0860 N1 = NA - 1 0870 DO 9 J = 1,N1 0880 J2 = J + 1 0890 DO 9 I = J2,NA 0900 SUM = 0. 0910 I1 = I - 1 0920 DO 8 K = J,I1 0930 8 SUM = SUM + A(I,K) * A(K,J) 0940 9 A(I,J) = - A(I,I) * SUM 0950 C CONSTRUCTION OF INVERSE OF INPUT MATRIX 0960 10 DO 15 J = 1,NA 0970 IF(J .EQ. 1) GO TO 12 0980 J1 = J - 1 0990 DO 11 I = 1,J1 1000 11 A(I,J) = A(J,I) 1010 12 DO 14 I = J,NA 1020 SUM = 0. 1030 DO 13 K = I,NA 1040 13 SUM = SUM + A(K,I) * A(K,J) 1050 14 A(I,J) = SUM 1060 15 CONTINUE 1070 RETURN 1080 16 WRITE(6,17) DETA 1090 17 FORMAT(10X, 'SINGULAR MATRIX IN CHOLD. DET =',E20.5) 1100 RETURN 1 1110 18 WRITE(6,19) 1120 19 FORMAT(10X,'MATRIX OF DIMENSION ZERO IN CHOLD') 1130 RETURN 1 1140 END 1150 SUBROUTINE PRINTP (MODE,LABEL,XLOWR,XHIGH,VALUE,NAME1,NAME2,LINE)SUBR1264 REAL*8 HEAD REAL*8 XLOWR,XHIGH,NAME1,NAME2,VALUE,XT,YT,ABS,FLOAT,DABS,DFLOAT, & XHI,XLO,SCALE REAL*8 X DIMENSION CHAR(121),HEAD(5),IAXIS(13) SUBR1265 DATA BLANK/4H / SUBR1266 DATA CHAR/121*1H / SUBR1267 DATA HEAD/8H*FR.OFF*,8H** DX **,8H** DY **,8H** DZ **,8H** DR **/ DATA IPLOT,JT/0,1/ SUBR1270 DATA CBL,CST,CX/1H ,1H*,1HX/ ABS(X)=DABS(X) INT(X)=IDINT(X) FLOAT(I)=DFLOAT(I) C SUBR1271 C .MODE. = 1 ... START NEW PLOT WITH .LABEL.TH HEADING, SUBR1272 C WITH LIMITS .XLOWR. LE .VALUE. LE .XHIGH., SUBR1273 C STATION NAMES .NAME1. AND .NAME2., SUBR1274 C AND ABCISSA STARTING AT .LINE. . SUBR1275 C = 2 ... PLOT .VALUE. IF IN RANGE (*), OR (X) SUBR1276 C IF OUT-OF-RANGE, AND PRINT POINT NO. SUBR1277 C IF A MULTIPLE OF 5 . SUBR1278 C = 3 ... PRINT ORDINATE AXIS TO FINISH PLOT . SUBR1279 C SUBR1280 GO TO (10,20,30),MODE SUBR1281 C SUBR1282 10 IPLOT = IPLOT + 1 SUBR1283 PRINT 5,IPLOT,HEAD(LABEL) SUBR1284 IF (LABEL.EQ.1) PRINT 15,NAME1 SUBR1285 IF (LABEL.GT.1.AND.NAME2.EQ.BLANK) PRINT 15,NAME1 SUBR1286 IF (LABEL.GT.1.AND.NAME2.NE.BLANK) PRINT 25,NAME1,NAME2 SUBR1287 PRINT 35,XLOWR,XHIGH SUBR1288 XT = (XHIGH - XLOWR) / 12. SUBR1289 SCALE = 10. / XT SUBR1290 DO 100 I=1,13 SUBR1291 YT = ABS (XLOWR + XT * FLOAT (I - 1)) SUBR1292 IAXIS(I) = INT (YT - FLOAT ((INT (YT) / 1000) * 1000)) SUBR1293 100 CONTINUE SUBR1294 PRINT 45,(IAXIS(I),I=1,13) SUBR1295 PRINT 55 SUBR1296 IL = LINE - 1 SUBR1297 XHI = XHIGH SUBR1298 XLO = XLOWR SUBR1299 RETURN SUBR1300 C SUBR1301 20 CHAR(JT)=CBL IL = IL + 1 SUBR1303 IT = IL - (IL / 5) * 5 SUBR1304 JT = INT ((VALUE - XLO) * SCALE + 1.5) SUBR1305 XT=CST IF(JT.LT.1.OR.JT.GT.121) XT=CX IF (JT.LT.1) JT = 1 SUBR1308 IF (JT.GT.121) JT = 121 SUBR1309 CHAR(JT) = XT SUBR1310 IF (IT.EQ.0) PRINT 65,IL,(CHAR(I),I=1,121),IL SUBR1311 IF (IT.GT.0) PRINT 75,(CHAR(I),I=1,121) SUBR1312 RETURN SUBR1313 C SUBR1314 30 PRINT 55 SUBR1315 PRINT 45,(IAXIS(I),I=1,13) SUBR1316 RETURN SUBR1317 C SUBR1318 5 FORMAT('1',/,58X,' P L O T S E T ',I2,/,58X, $ '--------------------',//,63X,A8,/) 15 FORMAT (62X,8HSTATION ,A4) SUBR1321 25 FORMAT (54X,8HSTATION ,A4,12H TO STATION ,A4) SUBR1322 35 FORMAT (/,54X,F11.2,6H TO ,F11.2,///) SUBR1323 45 FORMAT(6X,I3,12(7X,I3)) 55 FORMAT (7X,25(5H› )) SUBR1325 65 FORMAT (3X,I3,1H>,121A1,1H@,I3) SUBR1326 75 FORMAT (7X,121A1) SUBR1327 END SUBR1328 SUBROUTINE CHEBY (CH,DC,M,N,X,XP) SUBR3123 C SUBR3124 C SUBR3125 C WRITTEN BY P. LAWNIKANIS MARCH 1974. SUBR3126 C SUBR3127 C SUBR3128 C ›CHEBY› COMPUTES N-1ST CHEBYSHEV POLYNOMIALS SUBR3129 C FOR ARGUEMENT ›X› IN VECTOR ›CH›. SUBR3130 C DERIVATIVE POLYNOMIALS IN ›DC› FOR SUBR3131 C ›X› DERIVATIVE ›XP› IF ›J› = 1. SUBR3132 C SUBR3133 C SUBR3134 IMPLICIT REAL*8(A-H,O-Z) DIMENSION DC(N),CH(N) SUBR3135 FLOAT(I)=DFLOAT(I) IF (N) 10,10,20 SUBR3136 10 RETURN SUBR3137 C SUBR3138 20 CH(1) = 1. SUBR3139 CH(2) = X SUBR3140 IF (N.LT.3) RETURN SUBR3141 TX = X + X SUBR3142 DO 100 I = 3,N SUBR3143 CH(I) = CH(I-1) * TX - CH(I-2) SUBR3144 100 CONTINUE SUBR3145 IF (M.NE.1) RETURN SUBR3146 C SUBR3147 DC(1) = 0. SUBR3148 DC(2) = XP SUBR3149 DC(3) = (TX + TX) * XP SUBR3150 IF (N.LT.4) RETURN SUBR3151 DO 200 I = 4,N SUBR3152 J = I - 1 SUBR3153 K = I - 2 SUBR3154 DC(I) = DC(J) * FLOAT(J) / FLOAT(K) * TX SUBR3155 ! - DC(K) * FLOAT(J) / FLOAT(K-1) SUBR3156 200 CONTINUE SUBR3157 RETURN SUBR3158 C SUBR3159 END SUBR3160 SUBROUTINE MULTP (NRA,NCA,NCB,ND1,ND2,A,B,RES) SUBR2778 C SUBR2779 C SUBROUTINE COMPUTES A PRODUCT OF TWO GENERAL MATRICES A›*B SUBR2780 C NOTE NO. OF ROWS OF A = NO. OF ROWS OF B SUBR2781 C SUBR2782 C ND1 - ROW DIMENSION OF A AND B SUBR2783 C ND2 - ROW DIMENSION OF RES SUBR2784 REAL*8 A,B DIMENSION A(1), B(1), RES(1) SUBR2785 KB=-ND1 SUBR2786 KR=-ND2 SUBR2787 DO 1 J=1,NCB SUBR2788 KA=-ND1 SUBR2789 KB=KB+ND1 SUBR2790 KR=KR+ND2 SUBR2791 DO 1 I=1,NCA SUBR2792 KA=KA+ND1 SUBR2793 LR=KR+I SUBR2794 RES(LR)=0. SUBR2795 DO 1 II=1,NRA SUBR2796 LA=KA+II SUBR2797 LB=KB+II SUBR2798 1 RES(LR)=RES(LR)+A(LA)*B(LB) SUBR2799 RETURN SUBR2800 END SUBR2801 SUBROUTINE DDHHMM (MINI, IDHM) C C C 'DDHHMM '- AUTHOR P. G. LAWNIKANIS C - WRITTEN ON - OCTOBER /74 C - LAST COMPILED - APRIL 1975 C - REFERENCES - *NONE* C C VARIABLES USED -MINI, IDHM C C VARIABLES ALTERED -IDHM C C VARIABLES RETURNED -IDHM C C EXTERNAL ROUTINES - *NONE* C C I/O DEVICES -*NONE* C C DIMENSION IDHM(3) C IDHM(1) = MINI / 1440 IDHM(2) = (MINI-IDHM(1) * 1440) / 60 IDHM(3) = MINI- IDHM(1) * 1440 - IDHM(2) * 60 RETURN END FUNCTION MINUT(I,J,K) C C C "MINUT " - AUTHOR -P.G.LAWNIKANIS C - WRITTEN ON - SUMMER/74 C - LAST COMPILED - APRIL 1975 C - REFERENCES - *NONE* C C VARIABLES USED I,J,K C VARIABLES ALTERED - MINUT C VARIABLES RETURNED - MINUT C EXTERNAL ROUTINES - *NONE* C I/O DEVICES - *NONE* C MINUT=I*1440+J*60+K RETURN END