Thanks for using Compiler Explorer
Sponsors
Jakt
C++
Ada
Analysis
Android Java
Android Kotlin
Assembly
C
C3
Carbon
C++ (Circle)
CIRCT
Clean
CMake
CMakeScript
COBOL
C++ for OpenCL
MLIR
Cppx
Cppx-Blue
Cppx-Gold
Cpp2-cppfront
Crystal
C#
CUDA C++
D
Dart
Elixir
Erlang
Fortran
F#
Go
Haskell
HLSL
Hook
Hylo
ispc
Java
Julia
Kotlin
LLVM IR
LLVM MIR
Modula-2
Nim
Objective-C
Objective-C++
OCaml
OpenCL C
Pascal
Pony
Python
Racket
Ruby
Rust
Snowball
Scala
Solidity
Spice
Swift
LLVM TableGen
Toit
TypeScript Native
V
Vala
Visual Basic
Zig
Javascript
GIMPLE
fortran source #1
Output
Compile to binary object
Link to binary
Execute the code
Intel asm syntax
Demangle identifiers
Verbose demangling
Filters
Unused labels
Library functions
Directives
Comments
Horizontal whitespace
Debug intrinsics
Compiler
AARCH64 gfortran 10.5.0
AARCH64 gfortran 11.4.0
AARCH64 gfortran 12.1.0
AARCH64 gfortran 12.2.0
AARCH64 gfortran 12.3.0
AARCH64 gfortran 13.1.0
AARCH64 gfortran 13.2.0
AARCH64 gfortran 6.4
AARCH64 gfortran 7.3
AARCH64 gfortran 8.2
ARM (32bit) gfortran 10.5.0
ARM (32bit) gfortran 11.4.0
ARM (32bit) gfortran 12.1.0
ARM (32bit) gfortran 12.2.0
ARM (32bit) gfortran 12.3.0
ARM (32bit) gfortran 13.1.0
ARM (32bit) gfortran 13.2.0
ARM (32bit) gfortran 6.4
ARM (32bit) gfortran 7.3
ARM (32bit) gfortran 8.2
LOONGARCH64 gfortran 12.2.0
LOONGARCH64 gfortran 12.3.0
LOONGARCH64 gfortran 13.1.0
LOONGARCH64 gfortran 13.2.0
MIPS gfortran 12.1.0
MIPS gfortran 12.2.0
MIPS gfortran 12.3.0
MIPS gfortran 13.1.0
MIPS gfortran 13.2.0
MIPS gfortran 4.9.4
MIPS gfortran 5.5.0
MIPS gfortran 9.5.0
MIPS64 gfortran 12.1.0
MIPS64 gfortran 12.2.0
MIPS64 gfortran 12.3.0
MIPS64 gfortran 13.1.0
MIPS64 gfortran 13.2.0
MIPS64 gfortran 4.9.4
MIPS64 gfortran 5.5.0
MIPS64 gfortran 9.5.0
MIPS64el gfortran 12.1.0
MIPS64el gfortran 12.2.0
MIPS64el gfortran 12.3.0
MIPS64el gfortran 13.1.0
MIPS64el gfortran 13.2.0
MIPS64el gfortran 4.9.4
MIPS64el gfortran 5.5.0
MIPS64el gfortran 9.5.0
MIPSel gfortran 12.1.0
MIPSel gfortran 12.2.0
MIPSel gfortran 12.3.0
MIPSel gfortran 13.1.0
MIPSel gfortran 13.2.0
MIPSel gfortran 4.9.4
MIPSel gfortran 5.5.0
MIPSel gfortran 9.5.0
POWER gfortran 12.1.0
POWER gfortran 12.2.0
POWER gfortran 12.3.0
POWER gfortran 13.1.0
POWER gfortran 13.2.0
POWER64 gfortran 12.1.0
POWER64 gfortran 12.2.0
POWER64 gfortran 12.3.0
POWER64 gfortran 13.1.0
POWER64 gfortran 13.2.0
POWER64 gfortran trunk
POWER64le gfortran 12.1.0
POWER64le gfortran 12.2.0
POWER64le gfortran 12.3.0
POWER64le gfortran 13.1.0
POWER64le gfortran 13.2.0
POWER64le gfortran trunk
RISC-V 32-bits gfortran (trunk)
RISC-V 32-bits gfortran 12.1.0
RISC-V 64-bits gfortran (trunk)
RISC-V 64-bits gfortran 12.1.0
RISCV (32bit) gfortran 11.4.0
RISCV (32bit) gfortran 12.2.0
RISCV (32bit) gfortran 12.3.0
RISCV (32bit) gfortran 13.1.0
RISCV (32bit) gfortran 13.2.0
RISCV64 gfortran 11.4.0
RISCV64 gfortran 12.2.0
RISCV64 gfortran 12.3.0
RISCV64 gfortran 13.1.0
RISCV64 gfortran 13.2.0
SPARC LEON gfortran 12.2.0
SPARC LEON gfortran 12.3.0
SPARC LEON gfortran 13.1.0
SPARC LEON gfortran 13.2.0
SPARC gfortran 12.2.0
SPARC gfortran 12.3.0
SPARC gfortran 13.1.0
SPARC gfortran 13.2.0
SPARC64 gfortran 12.2.0
SPARC64 gfortran 12.3.0
SPARC64 gfortran 13.1.0
SPARC64 gfortran 13.2.0
flang-trunk (flang-new)
flang-trunk (flang-to-external-fc)
power64 AT12.0
power64 AT13.0
power64le AT12.0
power64le AT13.0
s390x gfortran 12.1.0
s390x gfortran 12.2.0
s390x gfortran 12.3.0
s390x gfortran 13.1.0
s390x gfortran 13.2.0
x86-64 gfortran (trunk)
x86-64 gfortran 10.1
x86-64 gfortran 10.2
x86-64 gfortran 10.3
x86-64 gfortran 10.4
x86-64 gfortran 10.5
x86-64 gfortran 11.1
x86-64 gfortran 11.2
x86-64 gfortran 11.3
x86-64 gfortran 11.4
x86-64 gfortran 12.1
x86-64 gfortran 12.2
x86-64 gfortran 12.3
x86-64 gfortran 13.1
x86-64 gfortran 13.2
x86-64 gfortran 4.9.4
x86-64 gfortran 5.5
x86-64 gfortran 6.3
x86-64 gfortran 7.1
x86-64 gfortran 7.2
x86-64 gfortran 7.3
x86-64 gfortran 8.1
x86-64 gfortran 8.2
x86-64 gfortran 8.3
x86-64 gfortran 8.4
x86-64 gfortran 8.5
x86-64 gfortran 9.1
x86-64 gfortran 9.2
x86-64 gfortran 9.3
x86-64 gfortran 9.4
x86-64 ifort 19.0.0
x86-64 ifort 2021.1.2
x86-64 ifort 2021.10.0
x86-64 ifort 2021.11.0
x86-64 ifort 2021.2.0
x86-64 ifort 2021.3.0
x86-64 ifort 2021.4.0
x86-64 ifort 2021.5.0
x86-64 ifort 2021.6.0
x86-64 ifort 2021.7.0
x86-64 ifort 2021.7.1
x86-64 ifort 2021.8.0
x86-64 ifort 2021.9.0
x86-64 ifx (latest)
x86-64 ifx 2021.1.2
x86-64 ifx 2021.2.0
x86-64 ifx 2021.3.0
x86-64 ifx 2021.4.0
x86-64 ifx 2022.0.0
x86-64 ifx 2022.1.0
x86-64 ifx 2022.2.0
x86-64 ifx 2022.2.1
x86-64 ifx 2023.0.0
x86-64 ifx 2023.1.0
x86-64 ifx 2023.2.1
x86-64 ifx 2024.0.0
Options
Source code
PROGRAM ANALYZE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Modified 2004.02.18 for Compaq Visual Fortran (B.Ducarme) ! C Program ANALYZE, version 3.40 1997.09.21 Fortran 90. ! C ! C This file has 6372 records. ! C ! C Analysis of Earth tide observations. ! C ! C This program may be compiled (after apropriate modification of ! C routine GEOEXT): ! C ! C - under operation system UNIX with SUN Fortran-compiler. ! C ! C - under operation system MS-DOS with Lahey F77L3-compiler ! C version 5.10, options /4 /Z1. ! C ! C - under operation sytem MS-DOS with Lahey Fortran 90 compiler ! C version 2.00aa using options -nstchk -tp -fix -f90 -o2 ! C ! C The program ANALYZE allows the adjustment of tidal parameters ! C and meteorological parameters from equally sampled earth tide ! C observations. As observations can be used: ! C ! C tidal potential, gravity tides, tilt tides, vertical and ! C horizontal tidal displacements, vertical strain tides, ! C horizontal strain tides, areal strain, shear strain, volume ! C strain and ocean tides. ! C ! C For gravimeter records, a priori amplitude factors for the ! C tidal waves within one wave group are used from the WAHR-DEHANT ! C elliptical, uniformly rotating oceanless Earth with inelastic ! C mantle, liquid outer core and elastic inner core (PREM elastic ! C Earth model with mantle dispersion from ZSCHAU and WANG 1987) in ! C order to correct for the Earth response to tidal constituents of ! C different degree and order within one wave group. ! C ! C There may be used highpass/bandpass filtered Earth tide and ! C meteorological observations applying different FIR zero phase ! C numerical lowpass filters (parameter KFILT = 1) or original ! C Earth tide and meteorological observations (parameter KFILT=0). ! C ! C In case of applying highpass filtering, the observation blocks ! C must exceed the filter length. Observation blocks shorter than ! C the filter length are counted in the block table, but not used. ! C In case of highpass filtering, the Earth tide and meteorological ! C observations are splitted into a low frequency part (below 0.7 ! C cycle per day) and a high frequency part (above 0.7 cycle per ! C day) by numerical filtering. The meteorological parameters and ! C the tidal parameters for daily to quarter daily waves may be ! C adjusted from the highpass filtered Earth tide and meteorologi- ! C cal hourly observations. ! C ! C In case of no highpass filtering, the tidal parameters may be ! C adjusted for long- to short periodic waves. In this case, ! C additional TSCHEBYSCHEFF polynomial bias parameters of different ! C degree (to be input per block) may be adjusted for each block in ! C order to compensate the drift of the Earth tide sensor. The ! C polynomial degree per block should not exceed the block length ! C divided by the longest period of the tidal waves, for which ! C parameters will be adjusted. You should use at least one bias ! C parameter per block in order to compensate for offsets. ! C ! C For a block with N hourly observations, numbered from J=1...N, ! C the drift for observation no. J can be computed from the ad- ! C justed TSCHEBYSCHEFF polynomial bias parameters DBIAS by ! C ! C DTN=(DBLE(J-1)-DBLE(N-1)*0.5D0)/(DBLE(N-1)*0.5D0) ! C DAK(1)=1.D0 ! C DAK(2)=DTN ! C DRIFT=DBIAS(1)*DAK(1)+DBIAS(2)*DAK(2) ! C DO 4560 I=3,NBIAS ! C DAK(I)=2.D0*DTN*DAK(I-1)-DAK(I-2) ! C 4560 DRIFT=DRIFT+DBIAS(I)*DAK(I) ! C ! C Although the adjustment of TSCHEBYSCHEFF polynomials has been ! C tested with simulated data up to degree 100, it is recommended ! C to use low degree polynomials only, especially when using the ! C HANN window for least squares adjustment. The drift approxi- ! C mation should in any case be checked by e.g. plotting the ! C residuals after adjustment. ! C ! C The error estimation for the adjusted tidal parameters is done ! C in two different ways: ! C ! C - by the least squares adjustment procedure, neglecting the ! C autocorrelation of the noise, ! C ! C - by FOURIER-amplitude spectrum of the residuals. ! C ! C The error estimation by FOURIER.amplitude spectrum of the ! C residuals is known to be more realistic than the error estima- ! C tion from the least squares adjustment procedure because the ! C neglected autocorrelation of the noise within the least squares ! C adjustment procedure. ! C ! C For the least squares adjustment of tidal parameters, there may ! C be applied the unity window of the HANN-window for each block ! C (e.g. Schueller 1976). In the case of no highpass filtering for ! C the adjustment of longperiodic tidal parameters, the application ! C of the HANN-window may produce large errors of the drift approxi-! C mation at the start and end of a block. This should be checked ! C by plotting the residuals, and in case of problems the appli- ! C cation of the unity window may provide a more stable drift ! C approximation. ! C ! C ! C Program options: ! C ---------------- ! C ! C There may be used ! C - equally sampled data at sampling interval 5 min, 10 min, 20 ! C min, 30 min or 60 min, ! C - highpass filtering of the observations or drift modelling by ! C TSCHEBYSCHEFF polynomials, ! C - eight numerical FIR filters of different length and quality, ! C - up to five additional observed meteorological parameters, ! C - seven different tidal potential developments (Doodson 1921, ! C Cartwright-Tayler-Edden 1973, Buellesfeld 1985, Tamura 1987, ! C Xi 1989, Roosbeek 1996 and Hartmann and Wenzel 1995) ! C may be used, ! C - for the least squares adjustment, the unity window or the HANN ! C window can be applied for the weights. ! C ! C Program restrictions: ! C --------------------- ! C ! C The program is not restricted to the processing of equidistant ! C Earth tide readings (e.g. 5 min of 1 h sampling interval). The ! C number of samples within one block (i.e. without interruption) ! C is not restricted, and up to 300 blocks may be processed with ! C the current program version. ! C ! C The number of wave groups to be analyzed is restricted to 85, ! C The number of additional meteorological parameters, for which ! C linear regression paraneters may be adjusted, is restricted to ! C 8. The total number of unknowns is restricted to 175. ! C ! C Disc file description: ! C ---------------------- ! C ! C PROJECT: Formatted unit, on which the project names 'CPROJ' ! C have to be stored in the first record, starting at ! C column 1 (8 characters at maximum). ! C 'CPROJ'.ini: Formatted unit, on which the control parameters of ! C the tidal observations have to be stored before the! C execution of program ANALYZE. ! C 'CPROJ'.dat: Formatted unit, on which the tidal observations ! C have to be stored before the execution of program ! C ANALYZE. ! C 'CPROJ'.prn: Formatted printout file. ! C 'CPROJ'.res: Formatted residual file. The residuals stored on ! C this file may be plotted using programs ! C PLOTDATA.FOR and PLOTHISTO.FOR. ! C 'CPROJ'.far: Formatted FOURIER amplitude spectrum file. ! C This file may be used by plotprogram PLOTSPEC.FOR. ! C 'CPROJ'.neq: Formatted normal equation system file. ! C This file may be used to store the normal equation ! C system (if controlparameter STORENEQSY=1) which ! C will be computed by program ANALYZE. ! C 'CPROJ'.par: Formatted file which will contains the adjusted ! C tidal parameters after the execution of program ! C ANALYZE. This file may be used to transfer the ! C adjusted tidal parameters into a data base. ! C default.ini: Formatted file, which contains default control ! C parameters for the execution of program ANALYZE. ! C The default control parameters will be overridden ! C by the actual control parameters read from file(s) ! C 'CPROJ'.ini. The path for this file is ! C \eterna33\hourdat\default.ini. ! C doodsehw.dat: Formatted file, on which the Doodson (1921) tidal ! C potential catalogue has to be stored before the ! C execution of program ANALYZE. ! C The path for this file is ! C \eterna33\commdat\doodsehw.dat. ! C doodsehw.uft: Unformatted file, on which the Doodson (1921) ! C tidal potential catalogue will be stored by the ! C first execution of program ANALYZE, if it does not ! C yet exist. The path for this file is ! C \eterna33\commdat\doodsehw.uft. ! C cted73hw.dat: Formatted file, on which the Cartwright and Tayler ! C (1971) and Cartwright and Edden (1973) tidal ! C potential catalogue has to be stored before the ! C execution of program ANALYZE. ! C The path for this file is ! C \eterna33\commdat\cted73hw.dat. ! C cted73hw.uft: Unformatted file, on which the Cartwright and ! C Tayler (1971) and Cartwright and Edden (1973) ! C tidal potential catalogue will be stored by the ! C first execution of program ANALYZE, if it does not ! C yet exist. The path for this file is ! C \eterna33\commdat\cted73hw.uft. ! C buellehw.dat: Formatted file, on which the Buellesfeld (1985) ! C tidal potential catalogue has to be stored before ! C the execution of program ANALYZE. ! C The path for this file is ! C \eterna33\commdat\buellehw.dat. ! C buellehw.uft: Unformatted file, on which the Buellesfeld (1985) ! C tidal potential catalogue will be stored by the ! C first execution of program ANALYZE, if it does not ! C yet exist. The path for this file is ! C \eterna33\commdat\buellehw.uft. ! C tamurahw.dat: Formatted file, on which the Tamura (1987) ! C tidal potential catalogue has to be stored before ! C the execution of program ANALYZE. ! C The path for this file is ! C \eterna33\commdat\tamurahw.dat. ! C tamurahw.uft: Unformatted file, on which the Tamura (1987) ! C tidal potential catalogue will be stored by the ! C first execution of program ANALYZE, if it does not ! C yet exist. The path for this file is ! C \eterna33\commdat\tamurahw.uft. ! C xi1989hw.dat: Formatted file, on which the Xi (1989) tidal ! C potential catalogue has to be stored before the ! C execution of program ANALYZE. ! C The path for this file is ! C \eterna33\commdat\xi1989hw.dat. ! C xi1989hw.uft: Unformatted file, on which the Xi (1989) tidal ! C potential catalogue will be stored by the first ! C execution of program ANALYZE, if it does not yet ! C exist. The path for this file is ! C \eterna33\commdat\xi1989hw.uft. ! C ratgp95.dat: Formatted file, on which the Roosbeek (1986) tidal ! C potential catalogue has to be stored before the ! C execution of program ANALYZE. ! C The path for this file is ! C \eterna33\commdat\ratgp95.dat. ! C ratgp95.uft: Unformatted file, on which the Roosbeek (1986) ! C tidal potential catalogue will be stored by the ! C first execution of program AMALYZE, if it does not ! C yet exist. The path for this file is ! C \eterna33\commdat\ratgp95.uft. ! C hw95s.dat: Formatted file, on which the Hartmann and Wenzel ! C (1995) tidal potential catalogue has to be stored ! C before the execution of program ANALYZE. ! C The path for this file is ! C \eterna33\commdat\hw95.dat. ! C hw95s.uft: Unformatted file, on which the Hartmann and Wenzel ! C (1995) tidal potential catalogue will be stored by ! C the first execution of program ANALYZE, if it does ! C not yet exist. The path for this file is ! C \eterna33\commdat\hw95.uft. ! C etpolut1.dat: Formatted file, on which the pole coordinates and ! C DUT1 corrections have to be stored before the ! C execution of program ANALYZE. ! C The path for this file is ! C \eterna33\commdat\etpolut1.dat. ! C etpolut1.uft: Unformatted direct access file, on which the pole ! C coordinates and DUT1 corrections will be stored by ! C the first execution of program ANALYZE, if it does ! C not yet exist. The path for this file is ! C \eterna33\commdat\etpolut1.uft. ! C *.nlf: Formatted file, on which the numerical FIR zero ! C phase lowpass filter has to be stored in case ! C parameter KFILT=1. There are available numerical ! C filters for different sampling intervals and with ! C different filter length and filter quality. ! C The path for this file is ! C \eterna33\commdat\*.nlf. ! C IUN12: unformatted scratch unit (residuals). ! C IUN20: unformatted scratch direct access unit for storage ! C of the observations. ! C ! C Used routines: ! C -------------- ! C ! C CHOLIN: Computes inverse of normal equation matrix. ! C ETASTE: Computes astronomical elements. ! C ETBUFF: Stores data for NC channels in buffer. ! C ETDDTA: Reads table of DDT=TDB-UTC ! C ETDDTB: Interpolates DDT=TDB-UTC from table ! C ETERIN: Reads control parameters ! C ETFILT: Parallel filtering for NC channels stored in buffer. ! C ETGCOF: Computes geodetic coefficients. ! C ETGREI: Computes GREGORIAN date. ! C ETINPD: Reads observations. ! C ETJULN: Computes JULIAN date. ! C ETLEGN: Computes fully normalized spherical harmonics. ! C ETLFIN: Reads numerical lowpass filter. ! C ETLOVE: Computes latitude dependent elastic parameters. ! C ETPHAS: Computes phases and frequencies of the tidal waves. ! C ETPOLC: Returns pole coordinates, DUT1 and pole tide. ! C ETPOTS: Reads tidal potential catalogues. ! C ETSDER: Searches for data errors. ! C GEOEXT: Computes jobtime. ! C JACOBI: Computes eigenvalues and spectral condition number. ! C ! C Loop index description within main program: ! C ------------------------------------------- ! C ! C IF is a loop index running over the filter length (1...NFI).! C IG is a loop index running over the wavegroups (1...NGR).! C IM is a loop index running over the meteoro. param. (1...NF). ! C IO is a loop index running over the observations (1...NO). ! C JO is a loop index running over the observations (1...NO). ! C IU is a loop index running over the unknowns (1...NU). ! C JU is a loop index running over the unknbowns (1...NU). ! C IW is a loop index running over the tidal waves (1...NW). ! C IFR is a loop index running over FOURIER frequencies (1...NFR). ! C ! C Numerical accuracy: ! C ------------------- ! C ! C The program has been tested on CDC CYBER 990 of RRZN Hannover ! C with 15 digits in single precision, on IBM-AT with 15 digits ! C in DOUBLE PRECISION, and on a SUN SPARC2 under UNIX with 15 ! C digits in DOUBLE PRECISION, and achieved the same results. ! C ! C Execution time: ! C --------------- ! C ! C The CPU execution time of ANALYZE depends mainly on the number ! C of earth tide observations to be processed, the tidal potential ! C to be used and the number of tidal parameters to be adjusted. ! C The execution time has been measured with three different data ! C sets on a number of different processors using under operation ! C system UNIX the SUN-Fortran compiler, under operation system ! C MS-DOS the Microsoft 5.0 Fortran compiler (abbreviated to ! C MS-FTN5) and the LAHEY F77L3 compiler (abbreviated to LAHEY): ! C ! C ! C operation system: MS-DOS MS-DOS MS-DOS MS-DOS ! C compiler: MS-FTN5 MS-FTN5 MS-FTN5 LAHEY5 ! C processor: 286/287 386DX/387 386DX/387 386DX/387 ! C speed: 12 MHz 16 MHz 20 MHz 20 MHz ! C ! C sample file days ! C ! C HAL29901.DAT 63.5 (889)s 540.8 s (429.6)s (340.2)s ! C BFL24903.DAT 121.0 (2872)s 1629.2 s (1303.6)s (1022.5)s ! C BFD00801.DAT 110.0 s s s s ! C BHTT4003.DAT 1004.5 s s s s ! C ! C program version: ! C operation system: MS-DOS MS-DOS MS-DOS MS-DOS ! C compiler: MS-FTN5 LAHEY5 MS-FTN5 LAHEY5 ! C processor: 486DX 486DX 486DX2 486DX2 ! C speed: 33 MHz 33 MHz 66 MHz 66 MHz ! C ! C sample file days ! C ! C HAL29901.DAT 63.5 93.21 s (63.66)s 47.45 s 34.50 s ! C BFL24903.DAT 121.0 284.02 s (188.72)s 143.58 s 99.09 s ! C BFD00801.DAT 110.0 264.63 s s 133.41 s 92.54 s ! C BHTT4003.DAT 1004.5 s s s 1031.39 s ! C BFAL8793.DAT 2557.0 s s s s ! C ! C ! C program version: 3.20 3.20 ! C operation system: UNIX SOLARIS 2.3 ! C compiler: SUN-F77 SUN-FTN 3.0 ! C processor: SUN SPARC2 SUN SPARC 10/52 ! C speed: 40 Mc ! C 1 user 1 user ! C ! C sample file days ! C ! C HAL29901.DAT 63.5 (40.69)s (22.0)s ! C BFL24903.DAT 121.0 (117.62)s (65.0)s ! C BFD00801.DAT 122.0 s s ! C BHTT4003.DAT 1004.5 s s ! C BFAL8793.DAT 2557.0 s s ! C ! C program version: 3.20 3.20 3.20 ! C operation system: MS-DOS MS-DOS MS-DOS ! C processor: 486DX2 486DX2 486DX2 ! C speed: 66 MHz 66 MHz 66 MHz ! C compiler: MS-FTN5 F77L3 LF90/2.0 ! C ! C sample file days ! C ! C HAL29901.DAT 63.5 42.3 s 31.6 s 24.4 s ! C BFL24903.DAT 121.0 127.9 s 89.4 s 86.2 s ! C BFD00801.DAT 110.0 118.6 s 83.2 s s ! C BHTT4003.DAT 1004.5 1443.1 s 906.2 s s ! C BFAL8793.DAT 2557.0 3651.3 s 2283.1 s s ! C ! C program version: 3.20 3.20 3.20 ! C operation system: MS-DOS MS-DOS MS-DOS ! C processor: PENTIUM PENTIUM PENTIUM ! C speed: 100 MHz 100 MHz 100 MHz ! C compiler: MS-FTN5 F77L3 LF90/2.0 ! C ! C sample file days ! C ! C HAL29901.DAT 63.5 14.8 s 9.62 s 7.68 s ! C BFL24903.DAT 121.0 44.7 s 25.98 s 25.59 s ! C BFD00801.DAT 110.0 41.2 s 23.84 s 19.88 s ! C BHTT4003.DAT 1004.5 501.2 s 240.08 s 205.31 s ! C BFAL8793.DAT 2557.0 1270.3 s 605.88 s 523.44 s ! C ! C ! C program version: 3.30 3.30 ! C operation system: MS-DOS MS-DOS ! C processor: 486DX2 PENTIUM ! C speed: 66 MHz 100 MHz ! C compiler: LF90/2.0 LF90/2.0 ! C ! C sample file days ! C ! C HAL29901.DAT 63.5 . s 4.78 s ! C BFL24903.DAT 121.0 . s 14.06 s ! C BFD00801.DAT 110.0 . s 6.43 s ! C BHTT4003.DAT 1004.5 . s 85.19 s ! C BFAL8793.DAT 2557.0 . s 205.91 s ! C BFHW9501.DAT 2731.0 . s 1767.07 s ! C BFDE403F.DAT 2922.0 . s 1849.34 s ! C ! C References : ! C ------------ ! C ! C Buellesfeld, F.-J. (1985): Ein Beitrag zur harmonischen Dar- ! C stellung des gezeitenerzeugenden Potentials. Deutsche ! C Geodaetische Kommission, Reihe C, Heft Nr. 314, Muenchen ! C 1985. ! C ! C Cartwright, D.E. and R.J. Tayler (1971): New computations of the ! C tide generating potential. The Geophysical Journal, ! C vol. 23 no. 1, Oxford 1971. ! C ! C Cartwright, D.E. and A.C. Edden (1973): Corrected tables of ! C tidal harmonics. The Geophysical Journal, vol. 33, no. 3, ! C Oxford 1973. ! C ! C Chojnicki, T. (1973): Ein Verfahren zur Erdgezeitenanalyse in ! C Anlehnung an das Prinzip der kleinsten Quadrate. Mitteilun- ! C gen aus dem Institut fuer Theoretische Geodaesie der Uni- ! C versitaet Bonn Nr. 15, Bonn 1973. ! C ! C Dehant, V. (1987): Tidal Parameters for an Inelastic Earth. ! C Physics of the Earth and Planetary Interiors, 49, 97-116, ! C 1987. ! C ! C Doodson, A.T. (1921): The Harmonic Development of the Tide Gene- ! C rating Potential. Proceedings of the Royal Society, Series ! C A 100, 306-328, London 1921. Reprint in International ! C Hydrographic Revue vol.31 no. 1, Monaco 1954. ! C ! C Pertsev, B. (1957): On the calculation of drift curve in obser- ! C vation of bodily tides. Bulletin d' Informations, Marees ! C Terrestres, no. 5, 71-72, Bruxelles 1957. ! C ! C Pertsev, B. (1959): Ob outchetie spolzaniya nulia pir nablou- ! C denij ouprougikh prilivov, Izv. Akad. Naouk SSR, no. 4, ! C 1959. ! C ! C Schueller, K. (1976): Ein Beitrag zur Auswertung von Erdgezei- ! C tenregistrierungen. Deutsche Geodaetische Kommission, ! C Reihe C Heft Nr. 227, Muenchen 1976. ! C ! C Schueller, K. (1986): Simultaneous tidal and multi-channel input ! C analysis as implemented in the HYCON-method. Proceedings ! C 10th International Symposium on Earth Tides, 515-520, ! C Madrid 1986. ! C ! C Tamura, Y. (1987): A Harmonic Development of the Tide-generating ! C Potential. Bulletin d'Informations Marees Terrestres no. 99,! C 6813-6855, Bruxelles 1987. ! C ! C Vetter, M. and H.-G. Wenzel (1995): PREGRED - An interactive ! C graphical editor for digitally recorded tidal data. ! C Bulletin d'Informations Marees Terrestres, vol. 121, pp. ! C 9102-9107, Bruxelles 1995. ! C ! C Wahr, J.M. (1981): Body tides on an elliptical, rotating, ! C elastic and oceanless earth. Geophysical Journal of the ! C Royal astronomical Society, vol. 64, 677-703, 1981. ! C ! C Wenzel, H.-G. (1974): The correction of tidal force development ! C to ellipsoidal normal. Bulletin d'Informations Marees ! C Terrestres, Vol. 68, 3748-3790, Bruxelles 1974. ! C ! C Wenzel, H.-G. (1976): Some remarks to the analysis method of ! C Chojnicki. Bulletin d'Informations Marees Terrestres, ! C vol. 73, 4187-4191, Bruxelles 1976. ! C ! C Wenzel, H.-G. (1976): Zur Genauigkeit von gravimetrischen Erd- ! C gezeitenbeobachtunngen. Wissenschaftliche Arbeiten der ! C Lehrstuehle fuer Geodaesie, Photogrammetrie und Kartogra- ! C phie an der Technischen Universitaet Hannover Nr. 67, ! C Hannover 1976. ! C ! c Wenzel, H.-G. (1977): Estimation of accuracy for the Earth tide ! C analysis results. Bulletin d'Informations, Marees ! C Terrestres, Vol. 76, 4427-4445, Bruxelles 1977. ! C ! C Wenzel, H.-G. (1993): Tidal data processing on a pc. Proceedings ! C XII International Symposium on Earth Tides, Beijing 1993. ! C Science Press, 235-244, Beijing 1995. ! C ! C Wenzel, H.-G. (1994a): PRETERNA - a preprocessor for digitally ! C recorded tidal data. Bulletin d'Informations Marees ! C Terrestres, vol. 118, 8722-8734, Bruxelles 1994. ! C ! C Wenzel, H.-G. (1994b): Gezeitenpotential. Seminar der Deutschen ! C Geophysikalischen Gesellschaft, Oberwolfach 17.-21. Oktober ! C 1994. Mitteilungen der Deutschen Geophysikalischen Gesell- ! C schaft, Sonderband II/1995, S. 1-18, 1995. ! C ! C Wenzel, H.-G. (1994c): Erdgezeitenanalyse. Seminar der Deutschen ! C Geophysikalischen Gesellschaft, Oberwolfach 17.-21. Oktober ! C 1994. Mitteilungen der Deutschen Geophysikalischen Gesell- ! C schaft, Sonderband II/1995, S. 19-38, 1995. ! C ! C Wenzel, H.-G. (1994d): Earth tide data processing package ETERNA ! C 3.20. Bulletin d'Informations Marees Terrestres, vol. 120, ! C 9019-9022, Bruxelles 1994. ! C ! C Wenzel, H.-G. (1995): Format and structure for the exchange of ! C high precision tidal data. Bulletin d'Informations Marees ! C Terrestres, vol. 121, 9097-9101, Bruxelles 1995. ! C ! C Wenzel, H.-G. (1996a): Accuracy assessment for tidal potential ! C catalogues. Bulletin d'Informations Marees Terrestres, ! C vol. 124, 9394-9416, Bruxelles 1996. ! C ! C Wenzel, H.-G. (1996): The nanogal software: Earth tide data ! C processing package ETERNA 3.30. Bulletin d'Informations ! C Marees Terrestres, vol. 124, 9425-9439, Bruxelles 1996. ! C ! C Wenzel, H.-G. (1996): Zum Stand der Erdgezeitenanalyse. ! C Zeitschrift fuer Vermessungswesen, vol. 121, Heft 6, 242-255, ! C Stuttgart 1996. ! C ! C Wenzel, H.-G. (1997): Tide-generating potential for the Earth. ! C In: Wilhelm, H., W. Zuern and H.-G. Wenzel (editors): Tidal ! C phenomena, 10-26. Springer Verlag, Berlin 1997. ! C ! C Wenzel, H.-G. (1997): Analysis of earth tide observations. ! C In: Wilhelm, H., W. Zuern and H.-G. Wenzel (editors): Tidal ! C phenomena, 59-76. Springer Verlag, Berlin 1997. ! C C Wilhelm, H. and W. Zuern (1984): Tidal forcing field. ! C In: Landolt-Boernstein, Zahlenwerte und Funktionen aus ! C Naturwissenschaften und Technik, New series, group V, Vol. ! C 2, Geophysics of the Solid Earth, the Moon and the Planets,! C Berlin 1984. ! C ! C Zschau, J. and R. Wang (1981): Imperfect elasticity in the ! C Earth's mantle. Implications for Earth tides and long ! C period deformations. Proceedings of the 9th International ! C Symposium on Earth Tides, New York 1981, pp. 605-629, ! C editor J.T. Kuo, Schweizerbartsche Verlagsbuchhandlung, ! C Stuttgart 1981. ! C ! C Zuern, W. and H. Wilhelm (1984): Tides of the solid Earth. ! C In: LANDOLT-BOERNSTEIN, Zahlenwerte und Funktionen aus ! C Naturwissenschaften und Technik, New series, group V, Vol. ! C 2, Geophysics of the Solid Earth, the Moon and the Planets,! C Berlin 1984. ! C ! C Program creation: 1972.12.30 by Hans-Georg Wenzel, ! C Black Forest Observatory, ! C Universitaet Karlsruhe, ! C Englerstr. 7, ! C D-76128 KARLSRUHE 1, ! C Germany. ! C Tel: 0049-721-6082307, ! C FAX: 0049-721-694552. ! C e-mail: wenzel@gik.bau-verm.uni-karlsruhe.de ! C Last modification: 1997.09.20 by Hans-Georg Wenzel. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPLICIT DOUBLE PRECISION (D) IMPLICIT INTEGER (I-N) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C The next DIMENSION statement is concerning the maximum number of ! C projects MAXPROJ, which can be processed within one batch run ! C of program ANALYZE. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! PARAMETER (MAXPROJ=500) CHARACTER CPROJ(MAXPROJ)*8 CHARACTER*30 CFINI,CFDAT,CFPRN,CFRES,CFFAR,CFNEQ,CFPAR CHARACTER CTEXT(8)*10,CENDT*10,CUNIT(11)*8,CHEAD(10)*64 CHARACTER CMODEL(7)*22,CVERS*11,CWIND(2)*5,CBLOCK*10 CHARACTER CFILENLF*12 CHARACTER CINST*10,CPSTR*48,CINTERN*6,CMOB*10 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C The following DIMENSION statement is concerning the number of ! C observed meteorological parameters (multi channel input), which ! C is restricted to 8 in the current program version (parameter ! C MAXNF). ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! PARAMETER (MAXNF=8) INTEGER IUNF(MAXNF),IREG(MAXNF) DOUBLE PRECISION DMECOR(MAXNF) CHARACTER CFY1(MAXNF)*10,CFY2(MAXNF)*10 DIMENSION DCMAT(MAXNF,MAXNF) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C The following DIMENSION statement is concerning the number of ! C waves of the tidal potential development, which is 12935. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! PARAMETER (MAXNW=12935) DOUBLE PRECISION DTHAM(MAXNW),DGAIN(MAXNW) DOUBLE PRECISION DC0(MAXNW),DS0(MAXNW),DDC(MAXNW),DDS(MAXNW) COMMON /TIDWAVE/ NW,IWNR(12935),IAARG(12935,12),DX0(12935), 1 DX1(12935),DY0(12935),DY1(12935),DTHPH(12935),DTHFR(12935), 2 DBODY(12935) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C The following DIMENSION statements are concering the number of ! C frequencies, at which the FOURIER amplitude spectrum will be ! C computed (parameter MAXFR). ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! PARAMETER (MAXFR=1300) DOUBLE PRECISION DOC(MAXFR),DOS(MAXFR) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C The following DIMENSION statements are concerning the number of ! C wavegroups to be analyzed, which is 85 in the current program ! C version (parameter MAXWG). ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! PARAMETER (MAXWG=85) INTEGER NA(MAXWG),NE(MAXWG),IUC(MAXWG),IUS(MAXWG) DOUBLE PRECISION DFRA(MAXWG),DFRE(MAXWG),DAM(MAXWG),DFR(MAXWG), 1 DGAM(MAXWG),DDPH(MAXWG),DBOD(MAXWG),DFTFD(MAXWG),DFTFP(MAXWG), 2 DMG(MAXWG),DMP(MAXWG),DXA(MAXWG),DYA(MAXWG) CHARACTER CNSY(MAXWG)*4 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C The following DIMENSION statements are concerning the number of ! C blocks of data without interruption, which is 300 in the current ! C program version (parameter MAXNB). ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! PARAMETER (MAXNC=9,MAXNB=300) INTEGER IRECA(MAXNB),IRECE(MAXNB),IDATA(MAXNB),ITIMA(MAXNB), 1 IDATE(MAXNB),ITIME(MAXNB),IOB(MAXNB),NBIAS(MAXNB),IUBIAS(MAXNB), 2 IFLAG(MAXNB) DOUBLE PRECISION DSAPR(MAXNB),DSAPO(MAXNB),DTLAG(MAXNB), 1 DMEAN(MAXNC,MAXNB) CHARACTER CINSTR(MAXNB)*10 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C The following dimension statements are concerning the buffer, ! C which is used to store data for MAXNC channels. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DIMENSION DSTOR(MAXNC,2596) DIMENSION ITSTOR(2596),IDSTOR(2596),DFL(MAXNC),DFH(MAXNC) DIMENSION DCIN(MAXNC),DZERO(MAXNC) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C COMMON /STORE/: ! C ! C DSTOR... array(1:MAXNC,1:2596), in which the Earth tide and ! C meteorological observations are stored. ! C IDSTOR... array(1..2596), in which the date referring to the ! C observations is stored. ! C ITSTOR... array(1...2596), in which the time referring to ! C the observations is stored. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! COMMON /STORE/ DSTOR,IDSTOR,ITSTOR C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C The following DIMENSION statement is concering the number of ! C unknown parameters to be adjusted, which is 175 in the current ! C program version (parameter MAXNU). ! C The array DNVEC used for the storage of the normal equation ! C system is equivalence to array DSTOR used for the storage of the ! C observations during the numerical filtering. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! PARAMETER (MAXNU=175,MAXELM=(MAXNU+1)*(MAXNU+2)/2) CHARACTER CNUNK(MAXNU)*10 DOUBLE PRECISION DAK(MAXNU),DNEQ(MAXNU,MAXNU),DCOR(MAXNU,MAXNU) DOUBLE PRECISION DNVEC(MAXELM),DX(MAXNU),DNSCAL(MAXNU) EQUIVALENCE (DNVEC(1),DSTOR(1,1)) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C The following DIMENSION statement is concerning the different ! C numerical lowpass filters which can be used. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! PARAMETER (MAXFIL=2001) DOUBLE PRECISION DLF(MAXFIL) CHARACTER CFILT*12 COMMON /UNITS/ CUNIT,IC2 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C The following DIMENSION statement is concerning the table od DDT:! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DOUBLE PRECISION DDTTAB(3,300) COMMON /DDT/ DDTTAB,NDDTTAB C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C COMMON /CONST/: To be initialized by BLOCK DATA: ! C DPI: 3.1415.... DPI2: 2.D0*DPI ! C DRAD: DPI/180.D0 DRO: 180.D0/DPI ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! COMMON /CONST/ DPI,DPI2,DRAD,DRO COMMON /BLOCKR/ IRECA,IRECE,IDATA,ITIMA,IDATE,ITIME,IOB,NBIAS, 1 DSAPR,DSAPO,DTLAG,DMEAN COMMON /BLOCKC/ CINSTR C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Common /CONTROL3/: control parameters initialized on default by ! C block data or read from file CFINI: ! C DDTSEC: Sampling interval in sec. ! C DLAT: Ellipsoidal latitude of the station in degree. ! C DLON: Ellipsoidal longitude of the station in degree, positive ! C east of Greenwhich. ! C DH..ellipsoidal height of the station in m. ! C DG..gravity of the station in m/s**2. ! C DAZ... azimuth of the component in degree (only valid for tilt ! C and strain). ! C ! C Parameter IC defines the Earthtide component. ! C IC=-1: tidal potential in m**2/s**2. ! C IC= 0: vertical tidal acceleration (gravity tide) in nm/s**2 ! C (positive downwards). ! C IC= 1: horizontal tidal acceleration (tidal tilt) in azimuth ! C DAZ in mas = arc sec/1000. ! C IC= 2: vertical tidal displacement in mm. ! C IC= 3: horizontal tidal displacement in azimuth DAZ in mm. ! C IC= 4: vertical tidal strain in 10**-9 = nstr. ! C IC= 5: horizontal tidal strain in azimuth DAZ in 10**-9 = nstr. ! C IC= 6: areal tidal strain in 10**-9 = nstr. ! C IC= 7: shear tidal strain in 10**-9 = nstr. ! C IC= 8: volume tidal strain in 10**-9 = nstr. ! C IC= 9: ocean tides in millimeter. ! C ! C Parameter IR is a printout parameter for the tidal developments. ! C IR= 0 no printout of the tidal potential development. ! C IR =1 printout of the tidal potential development. ! C ! C DATLIM is the upper limit for data errors. If DATLIM is equal to ! C or below zero, no data errors will be searched for. ! C If the data errors exceed DATLIM, the execution of the ! C program ANALYZE will be terminated. ! C DAMIN is the truncation threshold of the tidal potential ! C catalogue in m**2/s**2. ! C ! C KFILT is a parameter for highpass filtering of the data before ! C analysis. ! C KFILT= 0: No highpass filtering applied. ! C KFILT= 1: Highpassfiltering applied. ! C ! C Parameter IPROBS enables the printout of the original observa- ! C tions. ! C IPROBS=0: no printout of original observations. ! C IPROBS=1: printout of original observations. ! C ! C Parameter IPRLF enables the printout of lowpass filtered ! C observations. Lowpass filtered observations may be used as an ! C estimate of the instrumental drift. ! C IPRLF= 0 no printout of lowpass filtered observations. ! C IPRLF= 1 printout of lowpass filtered observations. ! C ! C Parameter IMODEL selects the tidal potential catalogue which ! C will be used in the analysis. ! C IMODEL = 1: Doodson (1921) catalogue. ! C IMODEL = 2: CTED 1973 catalogue. ! C IMODEL = 3: Buellesfeld (1985) catalogue. ! C IMODEL = 4: Tamura (1987) catalogue. ! C IMODEL = 5: Xi (1989) catalogue. ! C IMODEL = 6: Roosbeek (1996) catalogue. ! C IMODEL = 7: Hartmann and Wenzel (1995) catallogue. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! COMMON /CONTROL3/ DDTSEC,DLAT,DLON,DH,DGRAV,DAZ,DFRA,DFRE,DFTFD, 1 DFTFP,DATLIM,DAMIN,DMECOR COMMON /CONTROL4/ IC,IR,ITYI,ITMI,ITDI,ITHI,IDA,KFILT,IPROBS, 1 IPRLF,IMODEL,IRIGID,IHANN,IQUICK,DPOLTC,DLODTC,IPOLTR,ISTNEQ, 2 NGR,NF,IREG,CFY1,CFY2,CINST,CNSY,CHEAD,CFILENLF DATA IUN4/4/,IUN15/15/,IUN16/16/,IUN17/17/ DATA IUN10/10/,IUN11/11/,IUN12/12/,IUN13/13/,IUN14/14/,IUN18/18/, 1 IUN20/20/,IUN27/27/,IUN30/30/,IUN31/31/,IUN50/50/ DATA CVERS/'3.40 970921'/,CWIND/'UNITY','HANN '/ DATA CENDT/'C*********'/ DATA CMODEL/'Doodson (1921) ', 2 'CTED (1973) ', 3 'Buellesfeld (1985) ', 4 'Tamura (1987) ', 5 'Xi (1989) ', 6 'Roosbeek (1996) ', 7 'Hartmann+Wenzel (1995)'/ DATA DZERO/9*0.D0/,DDTH/1.D0/ DCPD=DRO/15.D0 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Open the files: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C HP-UNIX: OPEN(UNIT=IUN15,FILE='project') C HP-UNIX: OPEN(UNIT=IUN17,FILE='analyze.prn') C MS-DOS: OPEN(UNIT=IUN15,FILE='project') OPEN(UNIT=IUN17,FILE='analyze.prn') WRITE(IUN17,17000) CVERS WRITE(*,17000) CVERS IPROJ=1 10 READ(IUN15,17009,END=20) CPROJ(IPROJ) IPROJ=IPROJ+1 IF(IPROJ.GT.MAXPROJ) THEN WRITE(*,*) ' *** number of projects exceeds parameter MAXPROJ' WRITE(*,*) ' *** ANALYZE executes the first MAXPROJ projects' WRITE(IUN17,*)' *** number of projects exceeds parameter MAXPROJ' WRITE(IUN17,*)' *** ANALYZE executes the first MAXPROJ projects' GOTO 20 ENDIF GOTO 10 20 CLOSE(UNIT=IUN15) NPROJ=IPROJ-1 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Read table of DDT = TDT - UTC: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IPRINT=0 CALL ETDDTA(IUN16,IUN27,IPRINT) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Open default parameter file default.ini: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C HP-UNIX: OPEN(UNIT=IUN50,FILE='default.ini',STATUS='OLD') C MS-DOS: OPEN(UNIT=IUN50,FILE='default.ini',STATUS='OLD') C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Loop over all projects: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DO 15100 IPROJ=1,NPROJ C HP-UNIX: CFINI= CPROJ(IPROJ) // '.ini' C HP-UNIX: CFDAT= CPROJ(IPROJ) // '.dat' C HP-UNIX: CFPRN= CPROJ(IPROJ) // '.prn' C HP-UNIX: CFRES= CPROJ(IPROJ) // '.res' C HP-UNIX: CFFAR= CPROJ(IPROJ) // '.far' C HP-UNIX: CFNEQ= CPROJ(IPROJ) // '.neq' C HP-UNIX: CFPAR= CPROJ(IPROJ) // '.par' C MS-DOS: CFINI= CPROJ(IPROJ) // '.ini' CFDAT= CPROJ(IPROJ) // '.dat' CFPRN= CPROJ(IPROJ) // '.prn' CFRES= CPROJ(IPROJ) // '.res' CFFAR= CPROJ(IPROJ) // '.far' CFNEQ= CPROJ(IPROJ) // '.neq' CFPAR= CPROJ(IPROJ) // '.par' write(*,*)cfini CLOSE(UNIT=IUN15) CLOSE(UNIT=IUN16) OPEN(UNIT=IUN15,FILE=CFINI,FORM='FORMATTED') OPEN(UNIT=IUN16,FILE=CFPRN,FORM='FORMATTED') OPEN(UNIT=IUN18,FILE=CFPAR,FORM='FORMATTED') WRITE(IUN16,17000) CVERS IRESET=1 ISCREEN=0 CALL GEOEXT(IUN16,IRESET,ISCREEN,DEXTIM,DEXTOT) CPSTR='Analysis started' CALL WPRINT(IUN17,IPROJ,CPROJ(IPROJ),CPSTR,DEXTIM) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Read default control parameters from file DEFAULT.INI: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IPRINT=0 CALL ETERIN(IUN50,IUN16,IPRINT) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Read actual control parameters from file CPROJ.INI: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IPRINT=1 CALL ETERIN(IUN15,IUN16,IPRINT) DDTH=DDTSEC/3600.D0 CLOSE(UNIT=IUN15) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Read numerical lowpass filter: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(KFILT.EQ.0) THEN NFI=1 DLF(1)=0.D0 CFILT='no filter' ENDIF IF(KFILT.NE.0) THEN IPOLTR=0 IPRINT=1 write(*,*)iun15,cfilenlf CALL ETLFIN(IUN16,IUN15,IPRINT,CFILENLF,DDTSEC,NFI,DLF,CFILT, 1 IERR) IF(IERR.EQ.1) GOTO 15000 ENDIF CPSTR='Tidal potential catalogue:'//CMODEL(IMODEL) CALL WPRINT(IUN17,IPROJ,CPROJ(IPROJ),CPSTR,DEXTIM) OPEN(UNIT=IUN15,FILE=CFDAT,FORM='FORMATTED') IF(IQUICK.EQ.0) THEN OPEN(UNIT=IUN10,FILE=CFRES,FORM='FORMATTED') OPEN(UNIT=IUN11,FILE=CFFAR,FORM='FORMATTED') ENDIF OPEN(UNIT=IUN12,FORM='UNFORMATTED',STATUS='SCRATCH') IF(ISTNEQ.EQ.1) THEN OPEN(UNIT=IUN13,FILE=CFNEQ,FORM='FORMATTED') ENDIF OPEN(UNIT=IUN20,ACCESS='DIRECT',STATUS='SCRATCH',RECL=80) C HP-UNIX: OPEN(UNIT=IUN30,FILE='../eterna34/commdat/etpolut1.dat', OPEN(UNIT=IUN30,FILE='/home/hwz/eterna34/commdat/etpolut1.dat', 1 FORM='FORMATTED',STATUS='OLD') C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Unit IUN4 will be opened by the call of routine HWPOTA. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Read data file header: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1000 READ(IUN15,17070) (CTEXT(I),I=1,8) WRITE(IUN16,17071) (CTEXT(I),I=1,8) WRITE(IUN10,17070) (CTEXT(I),I=1,8) WRITE(IUN11,17070) (CTEXT(I),I=1,8) IF(CTEXT(1).NE.CENDT) GOTO 1000 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Read Earth tide and meteorological observations. ! C NC = number of channels. ! C NB = number of blocks. ! C NREC = number of data records on direct access unit IUN20. ! C This program version is restricted to 300 blocks. If you want ! C to use more blocks, you have to modify the dimension statements ! C associated with parameter MAXNB. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! NC=NF+1 CALL ETINPD(IUN15,IUN16,IUN20,IPROBS,NC,DDTSEC,NB,NREC,NERR) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Read parameter IRIGID for applying rigid Earth amplitude factors.! C IRIGID is set to 1 for strain tides and oceanic tides. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(IC.GE.2) IRIGID=1 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Parameter IHANN is for applying a HANN-window for the least ! C squares adjustment (see ref. SCHUELLER 1976). ! C Parameter IQUICK is for stopping the execution after printout ! C of the adjusted parameters. In this case, neither the residuals ! C nor their spectrum will be computed. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CALL GEOEXT(IUN16,IRESET,ISCREEN,DEXTIM,DEXTOT) NFI2=NFI/2+1 WRITE(IUN16,17061) CFILT,NFI IF(DPOLTC.GT.0.0D0) WRITE(IUN16,17062) IF(DLODTC.GT.0.0D0) WRITE(IUN16,17063) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute JULIAN date for initial epoch. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DTHI=DBLE(ITHI) CALL ETJULN(IUN16,ITYI,ITMI,ITDI,DTHI,DTUT) DT=(DTUT-2415020.D0)/36525.D0 DT2000=(DTUT-2451544.D0)/36525.D0 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Establish direct access file for pole coordinates: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IPRINT=1 CALL ETPOLC(IUN16,IUN30,IUN31,IPRINT,DTUT,DCLAT,DSLAT,DCLON,DSLON, 1 DPOLX,DPOLY,DUT1,DTAI,DLOD,DGPOL,DGPOLP,DGLOD,IKENN) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute the tidal development for the specific component IC: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(IR.EQ.1) IPRINT=2 IPRINT=1 CALL ETPOTS(IUN14,IUN16,IUN24,IPRINT,IMODEL,DLAT,DLON,DH, 1 DGRAV,DAZ,IC,DTUT,DAMIN) IC2=IC+2 IPRINT=0 CLOSE(IUN4) CLOSE(IUN14) CALL GEOEXT(IUN16,IRESET,ISCREEN,DEXTIM,DEXTOT) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Read comment on 10 records: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! WRITE(IUN16,17011) CVERS WRITE(IUN16,17007) DO 2070 I=1,10 2070 WRITE(IUN16,17013) CHEAD(I) WRITE(IUN16,17008) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C The number of wavegroups is restricted to MAXWG. ! C The number of meteorological parameters is restricted to MAXNF. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(NGR.GT.MAXWG) WRITE(IUN16,17064) MAXWG IF(NF.GT.MAXNF) WRITE(IUN16,17065) MAXNF IF(NGR.GT.MAXWG.OR.NF.GT.MAXNF) GOTO 15000 JG=1 IF(NGR.EQ.0) GOTO 2085 WRITE(IUN16,17014) CUNIT(IC2) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Read wave groups and frequency transfer function of the instru- ! C ment. The wave group numbers are referring to the first column ! C of file ETCPOT.DAT, for all tidal potentials which may be used. ! C ! C Standard wavegroups for Earth tide analysis, depending on the ! C recorded time span: ! C ! C ! C ! C group > 1 month > 6 months > 1 year ! C from to from to from to ! C [cpd] [cpd] [cpd] [cpd] [cpd] [cpd] ! C ! C SA - - - - 0.002428 0.003425 ! C SSA - - 0.004710 0.010951 0.004710 0.010951 ! C MM 0.025812 0.044652 0.025812 0.044652 0.025812 0.044652 ! C MF 0.060132 0.080797 0.060132 0.080797 0.060132 0.080797 ! C MTM 0.096423 0.249951 0.096423 0.249951 0.096423 0.249951 ! C Q1 0.721500 0.906315 0.721500 0.906315 0.721500 0.906315 ! C O1 0.921941 0.940487 0.921941 0.940487 0.921941 0.940487 ! C M1 0.958086 0.974188 0.958086 0.974188 0.958086 0.974188 ! C P1 - - 0.989049 0.998028 0.989049 0.998028 ! C S1 - - - - 0.999853 1.000147 ! C K1 0.989049 1.011099 0.999853 1.011099 1.001825 1.003651 ! C PSI1 - - - - 1.005329 1.005623 ! C PHI1 - - - - 1.007595 1.011099 ! C J1 1.013689 1.044800 1.013689 1.044800 1.013689 1.044800 ! C OO1 1.064841 1.216397 1.064841 1.216397 1.064841 1.216397 ! C 2N2 1.719381 1.872142 1.719381 1.872142 1.719381 1.872142 ! C N2 1.888387 1.906462 1.888387 1.906462 1.888387 1.906462 ! C M2 1.923766 1.942753 1.923766 1.942753 1.923766 1.942753 ! C L2 1.958233 1.976926 1.958233 1.976926 1.958233 1.976926 ! C S2 1.991787 2.182843 1.991787 2.002885 1.991787 2.002885 ! C K2 - - 2.003032 2.182843 2.003032 2.182843 ! C M3 2.753244 3.081254 2.753244 3.081254 2.753244 3.081254 ! C M4 3.791964 3.937897 3.791964 3.937897 3.791964 3.937897 ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DMAXPE=1.D30 IF(NGR.EQ.0) GOTO 2086 DMAXPE=0.D0 DO 2080 IG=1,NGR C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Convert frequencies from cpd to rad per hour: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DFRA(JG)=DFRA(IG)*15.D0*DRAD DFRE(JG)=DFRE(IG)*15.D0*DRAD DO 2081 IW=1,NW DXT=DX0(IW)+DX1(IW)*DT2000 DYT=DY0(IW)+DY1(IW)*DT2000 DTHAM(IW)=DSQRT(DXT**2+DYT**2) DTHPH(IW)=DTHPH(IW)-DATAN2(DYT,DXT) IF(DTHFR(IW).LT.DFRA(JG)-1.D-7) NA(JG)=IW+1 IF(DTHFR(IW).LT.DFRE(JG)+1.D-7) NE(JG)=IW 2081 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Search for rigid Earth tide amplitude DAM, frequency DFR and ! C body tide amplitude factor DBOD of the main wave in the group: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DAM(JG)=0.D0 IUC(JG)=2*JG-1 IUS(JG)=2*JG CNUNK(2*JG-1)='X-wave-'//CNSY(JG) CNUNK(2*JG) ='Y-wave-'//CNSY(JG) DO 2090 IW=NA(JG),NE(JG) IF(IRIGID.EQ.1) DBODY(IW)=1.D0 IF(DTHAM(IW).LE.DAM(JG)) GOTO 2100 DAM(JG)=DTHAM(IW) DFR(JG)=DTHFR(IW)*DRO/15.D0 DBOD(JG)=DBODY(IW) 2100 CONTINUE 2090 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Check frequency of main wave in the group. ! C If the frequency is less than 0.5 cpd and the filter ! C parameter KFILT is not equal to zero, the tidal parameters ! C of the group cannot be estimated. Those wave groups are ! C automatically eleminated: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IWNRA=IWNR(NA(JG)) IWNRE=IWNR(NE(JG)) CNSY(JG)=CNSY(IG) DFTFD(JG)=DFTFD(IG) DFTFP(JG)=DFTFP(IG) IF(KFILT.NE.0.AND.DFR(JG).LT.0.5D0) THEN WRITE(IUN16,17010) 00,IWNRA,IWNRE,DAM(JG),DFR(JG),CNSY(JG), 1 DFTFD(JG),DFTFP(JG),DBOD(JG) GOTO 2080 ENDIF DPER=360.D0/DFR(JG) DMAXPE=DMAX1(DMAXPE,DPER) WRITE(IUN16,17016) JG,IWNRA,IWNRE,DAM(JG),DFR(JG),CNSY(JG), 1 DFTFD(JG),DFTFP(JG),DBOD(JG) JG=JG+1 2080 CONTINUE 2085 CONTINUE NGR=JG-1 2086 WRITE(IUN16,17017) IF(NF.EQ.0) GOTO 2120 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Print names CFY1 and units CFY2 of meteorological data: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DO 2110 IM=1,NF WRITE(IUN16,17019) IM,CFY1(IM),CFY2(IM) CNUNK(2*NGR+IM)=CFY1(IM) 2110 CONTINUE 2120 IF(NF.EQ.0) WRITE(IUN16,17020) CALL GEOEXT(IUN16,IRESET,ISCREEN,DEXTIM,DEXTOT) IF(NGR.EQ.0) GOTO 2215 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute frequency gain DGAIN for numerical highpass filter. ! C Array of amplitudes DTHAM contains now body tide amplitude ! C DTHAM*DBODY times frequency gain DGAIN of the numerical filter. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DO 2210 IW=NA(1),NE(NGR) DTM=DLF(NFI2)*0.5D0 DNFI2=DBLE(NFI+1)*0.5D0 DO 2260 J=1,NFI2-1 DF=(DBLE(J)-DNFI2)*DDTH 2260 DTM=DTM+DLF(J)*DCOS(DTHFR(IW)*DF) DGAIN(IW)=1.D0-2.D0*DTM IF(KFILT.EQ.0) DGAIN(IW)=1.D0 2210 DTHAM(IW)=DTHAM(IW)*DBODY(IW)*DGAIN(IW) 2215 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Check all blocks: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IU=2*NGR+NF DO 3060 JB=1,NB IFLAG(JB)=1 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C The block will not be used if the input NBIAS is less 0: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(NBIAS(JB).LT.0) THEN IFLAG(JB)=0 NBIAS(JB)=-NBIAS(JB) ENDIF IF(KFILT.NE.0) NBIAS(JB)=0 IB=IOB(JB) IF(IB.GT.NFI) GOTO 3050 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C The current block is shorter than the filter length and will ! C thus be eliminated from the analysis. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! WRITE(IUN16,17086) JB,IDATA(JB),ITIMA(JB),IDATE(JB),ITIME(JB) IFLAG(JB)=0 3050 CONTINUE DO 3070 IBIAS=1,NBIAS(JB) IU=IU+1 WRITE(CINTERN,'(2I3)') JB,IBIAS 3070 CNUNK(IU)='bias'//CINTERN 3060 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Write observation summary: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 3530 WRITE(IUN16,17011) CVERS WRITE(IUN16,17007) DO 3540 I=1,10 3540 WRITE(IUN16,17013) CHEAD(I) WRITE(IUN16,17008) WRITE(IUN16,17029) CUNIT(IC2) NOBS=0 DOBSH=0.D0 DO 3550 JB=1,NB NOBS=NOBS+IOB(JB)*IFLAG(NB) DT=DBLE(IOB(JB))*DDTH/24.0D0 DOBSH=DOBSH+DT IF(KFILT.GT.0) GOTO 3555 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Check number of bias parameters: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(NGR.EQ.0) DMAXPE=2.D0 DMAXNBI=DMAX1(2.D0,DBLE(IOB(JB))/DMAXPE) MAXNBI=DMAXNBI IF(NBIAS(JB).LE.MAXNBI) GOTO 3555 WRITE(IUN16,17076) JB,MAXNBI 3555 WRITE(IUN16,17030) JB,IDATA(JB),ITIMA(JB),IDATE(JB), 1 ITIME(JB),DT,DSAPR(JB),DTLAG(JB),NBIAS(JB),IFLAG(JB) 3550 CONTINUE WRITE(IUN16,17031) NB,IDATA(1),ITIMA(1),IDATE(NB), 1 ITIME(NB),DOBSH DRAY=24.D0/(DBLE(NOBS)*DDTH) IF(IHANN.EQ.1) DRAY=2.D0*DRAY DOBSD=DBLE(NOBS)*DDTH/24.D0 WRITE(IUN16,17032) NOBS*(1+NF) CLOSE(IUN15) CALL GEOEXT(IUN16,IRESET,ISCREEN,DEXTIM,DEXTOT) CPSTR='Input of observations completed' CALL WPRINT(IUN17,IPROJ,CPROJ(IPROJ),CPSTR,DEXTIM) IF(NGR.EQ.0) GOTO 3570 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Check RAYLEIGH-criterion for wavegrouping: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DO 3560 JG=2,NGR IG=JG-1 DDFR=DFR(JG)-DFR(IG) IF(DABS(DDFR).LT.DRAY) WRITE(IUN16,17038) CNSY(IG),CNSY(JG) 3560 CONTINUE 3570 CONTINUE IF(NERR.EQ.0) GOTO 4000 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Sequence errors occured during input of data, program stops: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CPSTR='Sequence error dected in data' CALL WPRINT(IUN17,IPROJ,CPROJ(IPROJ),CPSTR,DEXTIM) CPSTR='Analyze stopped exeution for this project' CALL WPRINT(IUN17,IPROJ,CPROJ(IPROJ),CPSTR,DEXTIM) WRITE(IUN16,17034) GOTO 15100 4000 CONTINUE IF(IDA.EQ.0) GOTO 4100 IF(DDTSEC.LT.3599.D0) THEN WRITE(IUN16,17021) GOTO 4100 ENDIF NDL=0 DO 4110 JB=1,NB IF(IFLAG(JB).EQ.0) GOTO 4110 NO=IOB(JB) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Search for data errors: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CALL ETSDER(IUN16,IUN20,JB,NO,NC,DATLIM,NDLB) NDL=NDL+NDLB 4110 CONTINUE IF(NDL.EQ.0) GOTO 4100 CALL GEOEXT(IUN16,IRESET,ISCREEN,DEXTIM,DEXTOT) CPSTR='**** Execution stoppped because of data errors' CALL WPRINT(IUN17,IPROJ,CPROJ(IPROJ),CPSTR,DEXTIM) WRITE(IUN16,17037) CVERS GOTO 15100 4100 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Read data from direct access unit IUN20 and store part of them ! C them in buffer (does routine ETBUFF) : ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! NOB=0 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Define parameters for pole tide computation: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DCLAT=DCOS(DLAT*DRAD) DSLAT=DSIN(DLAT*DRAD) DCLON=DCOS(DLON*DRAD) DSLON=DSIN(DLON*DRAD) NCB=NC IF(IPOLTR.EQ.1) THEN NCB=NC+2 NF=NF+2 CFY1(NF-1)='pole tide' CFY2(NF-1)='nm/s**2' CFY1(NF) ='dpoltid/dt' CFY2(NF) ='nm/s**2/d' CNUNK(2*NGR+NF-1)=CFY1(NF-1) CNUNK(2*NGR+NF) =CFY1(NF) ENDIF DO 4210 JB=1,NB IF(IFLAG(JB).EQ.0) GOTO 4210 IF(IPRLF.NE.0) WRITE(IUN16,17035) CVERS,JB NO=IOB(JB) IO=0 IREC=IRECA(JB) READ(IUN20,REC=IREC) IDAT,ITIM IDUM=IDAT ITY =IDUM/10000 IDUM=IDUM-ITY*10000 ITM =IDUM/100 IDUM=IDUM-ITM*100 ITD=IDUM ITH=ITIM/10000 DTH=DBLE(ITH) CALL ETJULN(IUN16,ITY,ITM,ITD,DTH,DJULD0) IPRINT=0 DO 4220 IREC=IRECA(JB),IRECE(JB) READ(IUN20,REC=IREC) IDAT,ITIM,(DCIN(JC),JC=1,NC) IF(DPOLTC.GT.0.0D0.OR.DLODTC.GT.0.0D0.OR.IPOLTR.EQ.1) THEN C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute pole tide correction for an elastic earth model: ! C DPOLTC and DLODTC are amplitude factors read from input. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DJULD=DJULD0+DBLE(IO)*DDTH/24.D0 CALL ETPOLC(IUN16,IUN30,IUN31,IPRINT,DJULD,DCLAT,DSLAT,DCLON, 1 DSLON,DPOLX,DPOLY,DUT1,DTAI,DLOD,DGPOL,DGPOLP,DGLOD,IKENN) DCIN(1)=DCIN(1)-DPOLTC*DGPOL-DLODTC*DGLOD IF(IPOLTR.EQ.1) THEN DCIN(NCB-1)=DGPOL DCIN(NCB) =DGPOLP ENDIF ENDIF IO=IO+1 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Buffering of Earth tide and meteorological observations: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CALL ETBUFF(NFI,NCB,ISTOR,IDAT,ITIM,DCIN,IA,IE) IF(IO.LT.NFI) GOTO 4220 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Lowpass and highpass filtering: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CALL ETFILT(NFI,NFI2,DLF,NCB,IA,IE,IDF,ITF,DFL,DFH) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Remove average of samples in case of no highpass filtering: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(KFILT.EQ.0) THEN DO 4230 JC=1,NC 4230 DFH(JC)=DFH(JC)-DMEAN(JC,JB) ENDIF IF(IPRLF.NE.0) WRITE(IUN16,17033) IDF,ITF,(DFL(JC),JC=1,NC) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Store highpass filtered observation vector on IUN20: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IRECF=IREC-NFI2+1 WRITE(IUN20,REC=IRECF) IDF,ITF,(DFH(JC),JC=1,NCB) NOB=NOB+1 4220 CONTINUE 4210 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute normal equation system sequentially. We use only one ! C observation at a time. ! C NU = number of unknown parameters. ! C The sequence of unknowns is 2*NGR tidal parameters (2 for each ! C wave group), NF meteorological regression parameters, and ! C bias parameters for each block (in case of no highpass ! C filtering). ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! NU=2*NGR+NF DO 4460 IM=1,NF 4460 IUNF(IM)=2*NGR+IM C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Bias unknowns per block for KFILT=0. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(KFILT.GT.0) GOTO 4480 IU=NU+1 DO 4470 JB=1,NB IUBIAS(JB)=IU 4470 IU=IU+NBIAS(JB) NU=IU-1 NDF=NOB-NU 4480 CONTINUE IF(NU.GT.MAXNU) WRITE(IUN16,17069) MAXNU,NU C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Initialize normal equation matrix and right hand side: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! NELEM=(NU+1)*(NU+2)/2 DO 4505 K=1,NELEM 4505 DNVEC(K)=0.D0 DO 4600 JB=1,NB IF(IFLAG(JB).EQ.0) GOTO 4600 NO=IOB(JB)-NFI+1 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute weight for current block from a priori standard ! C deviation DSAPR. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DPB=1.D0/(DSAPR(JB)**2) DIB1=DPI2/DBLE(NO) DIB2=DBLE(NO-1)*0.5D0 DNO2=DBLE(NO-1)*0.5D0 DNO2I=1.D0/DNO2 IREC1=IRECA(JB)+NFI2-1 IREC2=IRECE(JB)-NFI2+1 JO=0 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Define updating interval DTULIM for the phases; ! C at each midnighht for DAMIN <= 1.D-8 m**2/s**2 ! C at monthly interval for 1.D-8 <= DAMIN <= 1.D-6 m**2/s**2, ! C at yearly interval for DAMIN > 1.D-6 m**2/s**2. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DTUPD=1.D99 DTULIM=24.D0 IF(DAMIN.GT.1.D-8) DTULIM=720.D0 IF(DAMIN.GT.1.D-6) DTULIM=8760.D0 IPRINT=0 DO 4590 IREC=IREC1,IREC2 READ(IUN20,REC=IREC) IDAT,ITIM,(DFH(JC),JC=1,NCB) CALL DATUM(IDAT,ITIM,ITY,ITM,ITD,DTH) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Update of phases, frequencies and amplitudes at midnight: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(DTUPD.GT.8770.D0) GOTO 4592 IF(DTH.GT.0.0001D0) GOTO 4595 IF(DTUPD.LT.DTULIM) GOTO 4595 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Update of phases, frequencies and amplitudes: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 4592 DTH=DTH-DTLAG(JB)/3600.D0 CALL ETJULN(IUN16,ITY,ITM,ITD,DTH,DJULD) DT2000=(DJULD-2451544.D0)/36525.D0 CALL ETPHAS(IUN16,IPRINT,IMODEL,DLON,DJULD) DO 4525 IG=1,NGR DO 4525 IW=NA(IG),NE(IG) DXT=(DX0(IW)+DX1(IW)*DT2000)*DBODY(IW)*DGAIN(IW) DYT=(DY0(IW)+DY1(IW)*DT2000)*DBODY(IW)*DGAIN(IW) DTHAM(IW)=DSQRT(DXT**2+DYT**2) DTHPH(IW)=DTHPH(IW)-DATAN2(DYT,DXT) DC0(IW)=DCOS(DTHPH(IW)) DS0(IW)=DSIN(DTHPH(IW)) DDC(IW)=DCOS(DTHFR(IW)*DDTH) 4525 DDS(IW)=DSIN(DTHFR(IW)*DDTH) DTUPD=0.D0 4595 CONTINUE JO=JO+1 DALJO=DFH(1) DO 4510 IU=1,NU 4510 DAK(IU)=0.D0 IF(NGR.EQ.0) GOTO 4535 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute observation equation and store it in array DAK. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DO 4530 IG=1,NGR DO 4530 IW=NA(IG),NE(IG) DAK(IUC(IG))=DAK(IUC(IG))+DTHAM(IW)*DC0(IW) DAK(IUS(IG))=DAK(IUS(IG))+DTHAM(IW)*DS0(IW) DUMMY =DC0(IW)*DDC(IW)-DS0(IW)*DDS(IW) DS0(IW) =DS0(IW)*DDC(IW)+DC0(IW)*DDS(IW) 4530 DC0(IW) =DUMMY 4535 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Observation equation for meteorological regression parameter: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(NF.EQ.0) GOTO 4550 DO 4540 IM=1,NF 4540 DAK(IUNF(IM))=DFH(IM+1) 4550 CONTINUE IF(KFILT.NE.0) GOTO 4570 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Observation equation for polynomial bias parameters. We use ! C TSCHEBYSCHEFF polynomials because they are orthogonal with ! C respect to normalized time and have excellent numerical ! C properties. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(NBIAS(JB).EQ.0) GOTO 4570 DTN=(DBLE(JO-1)-DNO2)*DNO2I IU=IUBIAS(JB) DAK(IU)=1.D0 IF(NBIAS(JB).EQ.1) GOTO 4570 IU=IU+1 DAK(IU)=DTN IF(NBIAS(JB).EQ.1) GOTO 4570 DO 4560 JU=3,NBIAS(JB) IU=IU+1 DAK(IU)=2.D0*DTN*DAK(IU-1)-DAK(IU-2) 4560 CONTINUE 4570 DPBJO=DPB C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute HANN-window for the current block: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(IHANN.EQ.1) DPBJO=DPBJO*(1.D0+DCOS((DBLE(JO-1)-DIB2)*DIB1)) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Update normal equation matrix, upper triangle only: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DAK(NU+1)=DALJO K=0 DO 4580 IU=1,NU+1 DO 4580 JU=1,IU K=K+1 4580 DNVEC(K)=DNVEC(K)+DAK(IU)*DAK(JU)*DPBJO 4590 DTUPD=DTUPD+DDTH 4600 CONTINUE CALL GEOEXT(IUN16,IRESET,ISCREEN,DEXTIM,DEXTOT) CPSTR='Normal equations computed' CALL WPRINT(IUN17,IPROJ,CPROJ(IPROJ),CPSTR,DEXTIM) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Store normal equation system: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(ISTNEQ.EQ.0) GOTO 4660 WRITE(IUN13,17090) CPROJ(IPROJ),NU DO 4610 IG=1,NGR WRITE(IUN13,17091) CPROJ(IPROJ),CNSY(IG),IUC(IG) WRITE(IUN13,17092) CPROJ(IPROJ),CNSY(IG),IUS(IG) 4610 CONTINUE IF(IM.EQ.0) GOTO 4630 DO 4620 IM=1,NF 4620 WRITE(IUN13,17093) CPROJ(IPROJ),CFY1(IM),IUNF(IM) 4630 CONTINUE IF(KFILT.GT.0) GOTO 4650 DO 4640 JB=1,NB IU=IUBIAS(JB) DO 4640 JU=1,NBIAS(JB) IEL=IU*(IU+1)/2 WRITE(IUN13,17094) CPROJ(IPROJ),JB,JU-1,IU 4640 IU=IU+1 4650 CONTINUE WRITE(IUN13,17095) (DNVEC(K),K=1,NELEM) 4660 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute normalization vector DNSCAL: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DO 4710 IU=1,NU K=IU*(IU-1)/2+IU 4710 DNSCAL(IU)=1.D0/DSQRT(DNVEC(K)) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Store normalized normal equation matrix in array DNEQ: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DO 4720 IU=1,NU DO 4720 JU=1,IU K=IU*(IU-1)/2+JU DNVEC(K)=DNVEC(K)*DNSCAL(IU)*DNSCAL(JU) DNEQ(IU,JU)=DNVEC(K) 4720 DNEQ(JU,IU)=DNVEC(K) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Normalize right hand side: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DO 4740 JU=1,NU K=NU*(NU+1)/2+JU 4740 DNVEC(K)=DNVEC(K)*DNSCAL(JU) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute spectral condition number DCOND of normalized normal ! C equation matrix: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CALL JACOBI(IUN16,DNEQ,NU,MAXNU,DAK,DCOR,NROT,DCOND) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Solve normal equation system: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CALL GEOEXT(IUN16,IRESET,ISCREEN,DEXTIM,DEXTOT) INV=1 CALL CHOLIN(IUN16,DNVEC,NU,INV,NSING) CALL GEOEXT(IUN16,IRESET,ISCREEN,DEXTIM,DEXTOT) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C De-normalize the inverse of the normal equation system: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DO 4750 IU=1,NU DO 4750 JU=1,IU K=IU*(IU-1)/2+JU 4750 DNVEC(K)=DNVEC(K)*DNSCAL(IU)*DNSCAL(JU) IFIRST=NU*(NU+1)/2 DO 5019 IU=1,NU 5019 DX(IU)=DNVEC(IFIRST+IU)*DNSCAL(IU) DVVP=DABS(DNVEC(NELEM)) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute standard deviation of weight unit: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! NDF=NOB-NU DMOBP=DSQRT(DVVP/DBLE(NDF)) CPSTR='Normal equations solved' CALL WPRINT(IUN17,IPROJ,CPROJ(IPROJ),CPSTR,DEXTIM) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute correlation matrix of unknowns: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ICORMAX=0 JCORMAX=0 DCORMAX=0.D0 DCORLIM=0.8D0 DO 4770 IU=1,NU DO 4770 JU=1,IU KIJ=IU*(IU-1)/2+JU KII=IU*(IU+1)/2 KJJ=JU*(JU+1)/2 DCOR(IU,JU)=DNVEC(KIJ)/DSQRT(DNVEC(KII)*DNVEC(KJJ)) IF(IU.NE.JU) THEN DACOR=DABS(DCOR(IU,JU)) IF(DACOR.GT.DCORMAX) THEN DCORMAX=DACOR ICORMAX=IU JCORMAX=JU ENDIF IF(DACOR.GT.DCORLIM) THEN WRITE(IUN16,17051) DCOR(IU,JU),CNUNK(IU),CNUNK(JU) ENDIF ENDIF 4770 CONTINUE DCORMAX=DCOR(ICORMAX,JCORMAX) WRITE(IUN16,17044) DMOBP,NDF,DCORMAX,CNUNK(ICORMAX),CNUNK(JCORMAX) IF(NGR.EQ.0) GOTO 5035 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute adjusted tidal parameters: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DO 5030 IG=1,NGR DXA(IG)=DX(2*IG-1) DYA(IG)=DX(2*IG) DCC=DSQRT(DXA(IG)**2+DYA(IG)**2) DCS=90.D0 IF(DABS(DXA(IG)).GE.1.D-11)DCS=-DRO*DATAN2(DYA(IG),DXA(IG)) DGAM(IG)=DCC*DBOD(IG)/DFTFD(IG) DDPH(IG)=DCS+DFTFP(IG) 5030 CONTINUE 5035 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Print adjusted parameters: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! WRITE(IUN16,17028) CVERS,CPROJ(IPROJ) WRITE(IUN16,17007) DO 5400 I=1,10 5400 WRITE(IUN16,17013) CHEAD(I) WRITE(IUN16,17008) WRITE(IUN16,17079) DLAT,DLON,DAZ NDF=NOB-NU DMOB=DSQRT(DVV/DBLE(NDF)) DMOBP=DSQRT(DVVP/DBLE(NDF)) WRITE(IUN16,17050) IDATA(1),IDATE(NB),NB,DOBSD WRITE(IUN16,17075) CMODEL(IMODEL),DAMIN,NW IF(IC2.EQ.2.AND.IRIGID.EQ.0) WRITE(IUN16,17080) IF(IC2.EQ.2.AND.IRIGID.EQ.1) WRITE(IUN16,17081) WRITE(IUN16,17082) CWIND(IHANN+1) WRITE(IUN16,17057) DDTSEC WRITE(IUN16,17061) CFILT,NFI IF(DPOLTC.GT.0.0D0) WRITE(IUN16,17062) IF(DLODTC.GT.0.0D0) WRITE(IUN16,17063) IF(NGR.EQ.0) GOTO 5430 WRITE(IUN16,17055) WRITE(IUN16,17043) CUNIT(IC2) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute standard deviation of adjusted tidal parameters: ! C DMG is standard deviation of amplitude factor. ! C DMP is standard deviation of phase lead in degree. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DO 5420 IG=1,NGR IU=2*IG-1 JU=2*IG IEL=IU*(IU+1)/2 JEL=JU*(JU+1)/2 DMG(IG)=DMOBP*DSQRT(DXA(IG)**2*DNVEC(IEL)+DYA(IG)**2* 1 DNVEC(JEL)+2.0*DXA(IG)*DYA(IG)*DNVEC(JEL-1))/ 2 DGAM(IG)*DBOD(IG)**2 DMP(IG)=DMOBP*DSQRT(DYA(IG)**2*DNVEC(IEL)+DXA(IG)**2* 1 DNVEC(JEL)-2.0*DXA(IG)*DYA(IG)*DNVEC(JEL-1))*DRO/ 2 (DXA(IG)**2+DYA(IG)**2) WRITE(IUN16,17046) DFRA(IG)*DCPD,DFRE(IG)*DCPD,CNSY(IG),DAM(IG), 1 DGAM(IG),DMG(IG),DDPH(IG),DMP(IG) 5420 CONTINUE 5430 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Print adjusted meteorological parameters: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(NF.EQ.0) GOTO 5450 WRITE(IUN16,17058) DO 5440 IM=1,NF IU=IUNF(IM) IEL=IU*(IU+1)/2 DM=DSQRT(DNVEC(IEL))*DMOBP 5440 WRITE(IUN16,17059) IM,DX(IU),DM,CFY1(IM),CUNIT(IC2),CFY2(IM) IF(NF.EQ.1) GOTO 5450 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Print correlation matrix of adusted metorological regression ! C parameters: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DO 5500 IM=1,NF IU=IUNF(IM) IEL=IU*(IU+1)/2 DO 5500 JM=1,IM DCMAT(IM,JM)=DNVEC(IEL-IM+JM) 5500 DCMAT(JM,IM)=DNVEC(IEL-IM+JM) DO 5510 IM=1,NF DO 5510 JM=1,NF IF(IM.NE.JM) DCMAT(IM,JM)=DCMAT(IM,JM)/DSQRT(DCMAT(IM,IM)* 1 DCMAT(JM,JM)) 5510 CONTINUE WRITE(IUN16,17087) (CFY1(IM),IM=1,NF) WRITE(IUN16,17088) DO 5520 IM=1,NF DCMAT(IM,IM)=1.D0 5520 WRITE(IUN16,17089) CFY1(IM),(DCMAT(IM,JM),JM=1,NF) 5450 CONTINUE IF(KFILT.NE.0) GOTO 5470 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Print adjusted TSCHEBYSCHEFF polynomial bias parameters: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! WRITE(IUN16,17077) DO 5460 JB=1,NB IU=IUBIAS(JB) DO 5455 JU=1,NBIAS(JB) IEL=IU*(IU+1)/2 DSBIAS=DMOBP*DSQRT(DNVEC(IEL)) WRITE(IUN16,17078) JB,JU-1,DX(IU),CUNIT(IC2),DSBIAS,CUNIT(IC2) 5455 IU=IU+1 5460 CONTINUE 5470 CONTINUE WRITE(IUN16,17044) DMOBP,NDF,DCORMAX,CNUNK(ICORMAX),CNUNK(JCORMAX) CALL GEOEXT(IUN16,IRESET,ISCREEN,DEXTIM,DEXTOT) IF(IQUICK.EQ.1) GOTO 15000 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute residuals. We compute only one residual at a time. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DVV=0.D0 DVVP=0.D0 NOB=0 DMAXRT=0.D0 DO 6330 JB=1,NB IF(IFLAG(JB).EQ.0) GOTO 6330 DPB=1.D0/(DSAPR(JB)**2) NO=IOB(JB)-NFI+1 NOB=NOB+NO DIB1=DPI2/DBLE(NO) DIB2=DBLE(NO-1)*0.5D0 CALL DATUM(IDATA(JB),ITIMA(JB),ITY,ITM,ITD,DTH) CALL ETJULN(IUN16,ITY,ITM,ITD,DTH,DT) DT=DT+DBLE(NFI2-1)*DDTH/24.D0 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Correct for TDT and instrumental time lag DTLAG: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CALL ETDDTB(IUN16,IPRINT,DT,DDT) DT=(DT-DTUT)*24.D0+(DDT-DTLAG(JB))/3600.D0 DSAPO(JB)=0.D0 DMAXR=0.D0 DPBJO=1.D0 WRITE(IUN12) DT DNO2=DBLE(NO-1)/2.D0 DNO2I=1.D0/DNO2 IREC1=IRECA(JB)+NFI2-1 IREC2=IRECE(JB)-NFI2+1 JO=0 CBLOCK='RESIDUALS' WRITE(IUN10,17002) CINSTR(JB),1.D0,DSAPR(JB),DTLAG(JB),NBIAS(JB), 1 CBLOCK WRITE(IUN10,17006) (DZERO(JC),JC=1,NCB),0.D0 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Define print limit for residuals: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DPRLIM=5.D0*DMOBP*DSAPR(JB) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Prepare arrays for recursion algorithm: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DTUPD=1.D99 IPRINT=0 DO 6150 IREC=IREC1,IREC2 READ(IUN20,REC=IREC) IDAT,ITIM,(DFH(JC),JC=1,NCB) CALL DATUM(IDAT,ITIM,ITY,ITM,ITD,DTH) IF(DTUPD.GT.8770.D0) GOTO 6152 IF(DTH.GT.0.0001D0) GOTO 6160 IF(DTUPD.LT.DTULIM) GOTO 6160 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Update of phases, frequencies and amplitudes. ! C DTUPD is time since last update in hours. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 6152 DTH=DTH-DTLAG(JB)/3600.D0 CALL ETJULN(IUN16,ITY,ITM,ITD,DTH,DJULD) DT2000=(DJULD-2451544.D0)/36525.D0 CALL ETPHAS(IUN16,IPRINT,IMODEL,DLON,DJULD) DO 6155 IG=1,NGR DO 6155 IW=NA(IG),NE(IG) DXT=(DX0(IW)+DX1(IW)*DT2000)*DBODY(IW)*DGAIN(IW) DYT=(DY0(IW)+DY1(IW)*DT2000)*DBODY(IW)*DGAIN(IW) DTHAM(IW)=DSQRT(DXT**2+DYT**2) DTHPH(IW)=DTHPH(IW)-DATAN2(DYT,DXT) DC0(IW)=DCOS(DTHPH(IW)) DS0(IW)=DSIN(DTHPH(IW)) DDC(IW)=DCOS(DTHFR(IW)*DDTH) 6155 DDS(IW)=DSIN(DTHFR(IW)*DDTH) DTUPD=0.D0 6160 CONTINUE JO=JO+1 DALJO=DFH(1) IF(NGR.EQ.0) GOTO 6095 DO 6090 IG=1,NGR DCC=0.D0 DCS=0.D0 DO 6080 IW=NA(IG),NE(IG) DCC=DCC+DTHAM(IW)*DC0(IW) DCS=DCS+DTHAM(IW)*DS0(IW) DUMMY =DC0(IW)*DDC(IW)-DS0(IW)*DDS(IW) DS0(IW)=DS0(IW)*DDC(IW)+DC0(IW)*DDS(IW) 6080 DC0(IW)=DUMMY DALJO=DALJO-DCC*DX(2*IG-1)-DCS*DX(2*IG) 6090 CONTINUE 6095 CONTINUE IF(NF.EQ.0) GOTO 6110 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Meteorological regression parameters: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DO 6100 IM=1,NF 6100 DALJO=DALJO-DFH(IM+1)*DX(IUNF(IM)) 6110 CONTINUE IF(KFILT.NE.0) GOTO 6130 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C TSCHEBYSCHEFF polynomial bias parameters: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(NBIAS(JB).EQ.0) GOTO 6130 IU=IUBIAS(JB) DTN=(DBLE(JO-1)-DNO2)*DNO2I DAK(IU)=1.D0 DALJO=DALJO-DAK(IU)*DX(IU) IF(NBIAS(JB).EQ.1) GOTO 6130 IU=IU+1 DAK(IU)=DTN DALJO=DALJO-DAK(IU)*DX(IU) IF(NBIAS(JB).EQ.2) GOTO 6130 DO 6120 JU=3,NBIAS(JB) IU=IU+1 DAK(IU)=2.D0*DTN*DAK(IU-1)-DAK(IU-2) 6120 DALJO=DALJO-DAK(IU)*DX(IU) 6130 CONTINUE DALJO=-DALJO WRITE(IUN12) DALJO C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute HANN-window for least squares adjustment: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(IHANN.EQ.1) DPBJO=(1.D0+DCOS((DBLE(JO-1)-DIB2)*DIB1)) DV2=DALJO**2 DVV=DVV+DPBJO*DV2 DVVP=DVVP+DPB*DPBJO*DV2 DSAPO(JB)=DSAPO(JB)+DPBJO*DV2 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Write highpass filtered data and residuals to IUN10: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! WRITE(IUN10,17033) IDAT,ITIM,(DFH(JC),JC=1,NCB),DALJO C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Store maximum residual of this block: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 6140 DABDAL=DABS(DALJO) IF(DABDAL.LT.DPRLIM) GOTO 6145 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Residual exceeds print limit: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! WRITE(IUN16,17023) IDAT,ITIM,DALJO 6145 CONTINUE IF(DABDAL.GE.DMAXR) THEN JOMAX=JO DMAXR=DABDAL ENDIF IF(DABDAL.GE.DMAXRT) DMAXRT=DABDAL 6150 DTUPD=DTUPD+DDTH WRITE(IUN10,17033) 99999999 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Print maximum residual of this block: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CALL DATUM(IDATA(JB),ITIMA(JB),ITY,ITM,ITD,DTH) DTH=DTH+(JOMAX-2+NFI2)*DDTH CALL ETGREI(ITY,ITM,ITD,DTH) DSAPO(JB)=DSQRT(DSAPO(JB)/DBLE(NO)*DBLE(NOB)/DBLE(NOB-NU)) WRITE(IUN16,17060) JB,ITY,ITM,ITD,ITH,DMAXR,CUNIT(IC2),DSAPO(JB), 1 CUNIT(IC2) 6330 CONTINUE WRITE(IUN10,17033) 88888888 NDF=NOB-NU DMOB=DSQRT(DVV/DBLE(NDF)) DMOBP=DSQRT(DVVP/DBLE(NDF)) WRITE(IUN16,17042) DMOB, CUNIT(IC2),NDF,DMAXRT,CUNIT(IC2),DCORMAX, 1 CNUNK(ICORMAX),CNUNK(JCORMAX),DCOND CALL GEOEXT(IUN16,IRESET,ISCREEN,DEXTIM,DEXTOT) CPSTR='Residuals computed' CALL WPRINT(IUN17,IPROJ,CPROJ(IPROJ),CPSTR,DEXTIM) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C FOURIER-spectrum of residuals, resolution .1 degree per hour. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! REWIND IUN12 NFR=1300 IF(NFR.GT.MAXFR) NFR=MAXFR DDFR=0.05D0 DDFRAD=DDFR*DRAD DO 6700 IFR=1,NFR DOC(IFR)=0.D0 6700 DOS(IFR)=0.D0 DO 6750 JB=1,NB IF(IFLAG(JB).EQ.0) GOTO 6750 NO=IOB(JB)-NFI+1 DIB=DBLE(NO) DIB1=DPI2/DIB DIB2=DBLE(NO-1)*0.5D0 READ(IUN12) DT DO 6740 IO=1,NO READ(IUN12) DALJO DALJO=DALJO*(1.D0+DCOS((DBLE(IO-1)-DIB2)*DIB1)) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Use recursion algorithm to compute Discrete Fourier Transform: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DCF=1.D0 DSF=0.D0 DDCI=DCOS(DDFRAD*DT) DDSI=DSIN(DDFRAD*DT) DO 6730 IFR=1,NFR DOC(IFR)=DOC(IFR)+DALJO*DCF DOS(IFR)=DOS(IFR)+DALJO*DSF DUMMY=DCF*DDCI-DSF*DDSI DSF =DSF*DDCI+DCF*DDSI 6730 DCF =DUMMY 6740 DT=DT+DDTH 6750 CONTINUE DOB4=2.D0/DBLE(NOB) WRITE(IUN16,17053) CUNIT(IC2) DO 6760 IFR=1,NFR 6760 DOC(IFR)=DSQRT(DOC(IFR)**2+DOS(IFR)**2)*DOB4 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C DMSEW is the theoretical average of amplitude spectrum of ! C residuals between 0 and the NYQUIST frequency, computed from ! C DMSEW = DMOB * DSQRT(DPI/NOB) ! C This parameter is used to scale up the estimated standard ! C deviations of parameters from least squares adjustment by the ! C frequency dependent noise amplitude. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DMSEW=DMOB*DSQRT(DPI/DBLE(NOB)) DO 6770 IFR=1,NFR,5 IFR11=IFR+4 DOM=DBLE(IFR-1)*DDFR 6770 WRITE(IUN16,17052) DOM,(DOC(JFR),JFR=IFR,IFR11) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Convert from degree per hour to cpd: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DDFRCPD=DDFR/15.D0 DO 6771 IFR=1,NFR DOM=DBLE(IFR-1)*DDFRCPD 6771 WRITE(IUN11,17056) DOM,DOC(IFR) CALL GEOEXT(IUN16,IRESET,ISCREEN,DEXTIM,DEXTOT) CPSTR='Spectrum of residuals computed' CALL WPRINT(IUN17,IPROJ,CPROJ(IPROJ),CPSTR,DEXTIM) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Estimation of noise by FOURIER-spectrum of residuals ! C DMSE0 is the constant of frequency dependent noise function for ! C the longperiodic band, NOISE(F)=DMSE0/F where F is the ! C frequency given in cpd. DMSE0 is adjusted from Fourier ! C amplitude spectrum of residuals between 0.1 and 2.9 deg/h. ! C DMSE1 is the average from 12.0 to 17.9 deg per hour (1 cpd) ! C DMSE2 is the average from 26.0 to 31.9 deg per hour (2 cpd) ! C DMSE3 is the average from 42.0 to 47.9 deg per hour (3 cpd) ! C DMSE4 is the average from 57.0 to 62.9 deg per hour (4 cpd) ! C DMSEW is the average from 0.0 to 65.0 deg per hour (0..4 cpd) ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DMSE0=0.D0 IAFR=(0.1001D0/DDFR)+1 IEFR=(2.9001D0/DDFR)+1 DO 6775 IFR=IAFR,IEFR 6775 DMSE0=DMSE0+DOC(IFR)*DBLE(IFR-1)*DDFRCPD DMSE0=DMSE0/DBLE(IEFR-IAFR+1) IF(KFILT.NE.0) DMSE0=9999.9999D0 DMSE1=0.D0 IAFR=(12.0001D0/DDFR)+1 IEFR=(17.9001D0/DDFR)+1 DO 6780 IFR=IAFR,IEFR 6780 DMSE1=DMSE1+DOC(IFR) DMSE1=DMSE1/DBLE(IEFR-IAFR+1) DMSE2=0.D0 IAFR=(26.0001D0/DDFR)+1 IEFR=(31.9001D0/DDFR)+1 DO 6790 IFR=IAFR,IEFR 6790 DMSE2=DMSE2+DOC(IFR) DMSE2=DMSE2/DBLE(IEFR-IAFR+1) DMSE3=0.D0 IAFR=(42.0001D0/DDFR)+1 IEFR=(47.9001D0/DDFR)+1 DO 6800 IFR=IAFR,IEFR 6800 DMSE3=DMSE3+DOC(IFR) DMSE3=DMSE3/DBLE(IEFR-IAFR+1) DMSE4=0.D0 IAFR=(57.0001D0/DDFR)+1 IEFR=(62.9001D0/DDFR)+1 DO 6805 IFR=IAFR,IEFR 6805 DMSE4=DMSE4+DOC(IFR) DMSE4=DMSE4/DBLE(IEFR-IAFR+1) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Print adjusted tidal parameters, estimation of noise by FOURIER- ! C spectrum of residuals. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! WRITE(IUN16,17028) CVERS,CPROJ(IPROJ) WRITE(IUN16,17007) DO 6810 I=1,10 6810 WRITE(IUN16,17013) CHEAD(I) WRITE(IUN16,17008) WRITE(IUN16,17079) DLAT,DLON,DAZ WRITE(IUN16,17050) IDATA(1),IDATE(NB),NB,DOBSD WRITE(IUN16,17075) CMODEL(IMODEL),DAMIN,NW IF(IC2.EQ.2.AND.IRIGID.EQ.0) WRITE(IUN16,17080) IF(IC2.EQ.2.AND.IRIGID.EQ.1) WRITE(IUN16,17081) WRITE(IUN16,17082) CWIND(IHANN+1) WRITE(IUN16,17057) DDTSEC WRITE(IUN16,17061) CFILT,NFI IF(DPOLTC.GT.0.0D0) WRITE(IUN16,17062) IF(DLODTC.GT.0.0D0) WRITE(IUN16,17063) IF(NGR.EQ.0) GOTO 6840 WRITE(IUN16,17054) CUNIT(IC2),DMSE0*10.D0,DMSE1,DMSE2,DMSE3,DMSE4, 1 DMSEW,CUNIT(IC2) DO 6830 IG=1,NGR IU=2*IG-1 JU=2*IG IEL=IU*(IU+1)/2 JEL=JU*(JU+1)/2 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Coloured noise assumption: ! C DMG contains the standard deviation of amplitude factor, ! C DMP contains the standard deviation of phase lead. ! C ! C DM is the average noise level in the specific frequency band! ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DM=DMSE0/DFR(IG) IF(DFR(IG).GT.0.5D0) DM=DMSE1 IF(DFR(IG).GT.1.5D0) DM=DMSE2 IF(DFR(IG).GT.2.5D0) DM=DMSE3 IF(DFR(IG).GT.3.5D0) DM=DMSE4 DMG(IG)=DMG(IG)*DM/DMSEW DMP(IG)=DMP(IG)*DM/DMSEW WRITE(IUN16,17046) DFRA(IG)*DCPD,DFRE(IG)*DCPD,CNSY(IG),DAM(IG), 1 DGAM(IG),DMG(IG),DDPH(IG),DMP(IG) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Output on CPROJ.PAR: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! WRITE(IUN18,17045) 'TIDALPARAM=',DFRA(IG)*DCPD,DFRE(IG)*DCPD, 1 DGAM(IG),DDPH(IG),CNSY(IG) WRITE(IUN18,17045) 'STDVTPARAM=',DFRA(IG)*DCPD,DFRE(IG)*DCPD, 1 DMG(IG),DMP(IG),CNSY(IG) 6830 CONTINUE 6840 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Print adjusted regression parameters for meteorological obs.: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(NF.EQ.0) GOTO 6860 WRITE(IUN16,17058) DO 6850 IM=1,NF IU=IUNF(IM) IEL=IU*(IU+1)/2 DM=DSQRT(DNVEC(IEL))*DMOBP IF(IPOLTR.NE.1) GOTO 6849 IF(IM.LT.NF-1) GOTO 6849 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Scale up standard deviation for pole tides using DMSE0/f ! C noise model for long periodic phenomena: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DM=DM*DMSE0*365.D0/DMSEW 6849 CONTINUE 6850 WRITE(IUN16,17059) IM,DX(IU),DM,CFY1(IM),CUNIT(IC2),CFY2(IM) IF(NF.EQ.1) GOTO 6860 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Print correlation matrix of adjusted meteorological regression ! C parameters: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! WRITE(IUN16,17087) (CFY1(IM),IM=1,NF) WRITE(IUN16,17088) DO 6870 IM=1,NF DCMAT(IM,IM)=1.D0 6870 WRITE(IUN16,17089) CFY1(IM),(DCMAT(IM,JM),JM=1,NF) 6860 CONTINUE IF(KFILT.NE.0) GOTO 6890 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Print TSCHEBYSCHEFF polynomial bias parameters: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! WRITE(IUN16,17077) DO 6880 JB=1,NB IU=IUBIAS(JB) DO 6880 JU=1,NBIAS(JB) IEL=IU*(IU+1)/2 DSBIAS=DMOBP*DSQRT(DNVEC(IEL)) WRITE(IUN16,17078) JB,JU-1,DX(IU),CUNIT(IC2),DSBIAS,CUNIT(IC2) 6880 IU=IU+1 6890 CONTINUE WRITE(IUN16,17042) DMOB, CUNIT(IC2),NDF,DMAXRT,CUNIT(IC2),DCORMAX, 1 CNUNK(ICORMAX),CNUNK(JCORMAX),DCOND WRITE(CMOB,'(F10.3)') DMOB CPSTR='Analysis finished, stdv.='//CMOB//' '//CUNIT(IC2) CALL WPRINT(IUN17,IPROJ,CPROJ(IPROJ),CPSTR,DEXTIM) 15000 CONTINUE CALL GEOEXT(IUN16,IRESET,ISCREEN,DEXTIM,DEXTOT) CLOSE(IUN15) CLOSE(IUN16) CLOSE(IUN10) CLOSE(IUN11) CLOSE(IUN12) CLOSE(IUN13) CLOSE(IUN14) CLOSE(IUN20) 15100 CONTINUE WRITE(IUN17,17067) DEXTOT WRITE(*,17067) DEXTOT C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Format statements: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 17000 FORMAT( 1' ******************************************************'/ 2' * *'/ 3' * Program ANALYZE, version ',A11,' Fortran 90. *'/ 4' * *'/ 5' * Analysis of earthtide observations. *'/ 6' * *'/ 7' * The Black Forest Observatory Schiltach *'/ 8' * wishes you much success when using ANALYZE. *'/ 9' * *'/ 9' ******************************************************'/) 17001 FORMAT(A40,5X,4I5) 17002 FORMAT(A10,5X,2F10.4,F10.3,I10,A10) 17003 FORMAT(' ') 17004 FORMAT(A40,F10.3) 17005 FORMAT(2I5) 17006 FORMAT('77777777',7X,8F10.3) 17007 FORMAT(5X,'#',66('#'),'#') 17008 FORMAT(5X,'#',66('#'),'#') 17009 FORMAT(A8) 17010 FORMAT(6X,'*** tidal parameters for next wave cannot be adjusted:' 1 /6X,I5,2I6,F10.4,F10.6,1X,A6,F9.4,F8.3,F12.5/) 17011 FORMAT(6X,'Program ANALYZE, version ',A11,' Fortran 90.'/) 17012 FORMAT(A64) 17013 FORMAT(5X,'# ',A64,' #') 17014 FORMAT(/// 1 6X,'Wave groups and parameters for main wave'/ 2 6X,'WD delta: a priori WAHR-DEHANT inelastic amplitude factor'// 3 6X,'No. from to ampl. frequency ', 4 'freq. transf. func. WD delta'/ 5 22X,A8,1X,3X,5H[cpd],21X,5H[deg]/) 17015 FORMAT(2F10.6,1X,A4,3X,4F10.4) 17016 FORMAT(6X,I5,2I6,F10.4,F10.6,1X,A6,F9.4,F8.3,F12.5) 17017 FORMAT(/// 1 6X,'Meteorological or hydrological parameters :'// 2 6X,'no. parameter unit'//) 17018 FORMAT(A10,2X,A10) 17019 FORMAT(6X,I3,2X,A10,2X,A10) 17020 FORMAT(6X,'no parameter') 17021 FORMAT(/ 1 6X,'***Search for gross errors impossible for this sampling', 2' interval.'/ 3 6X,'***Program ANALYZE continues execution.'/) 17023 FORMAT(6X,'*** large residual at:',I8,1X,I6,7F10.3) 17024 FORMAT(A8) 17028 FORMAT(///6X,'Program ANALYZE, version ',A11,' ',4X, 1'File: ', A8) 17029 FORMAT(/ 1 6X,'Summary of observation data :'// 2 6X,'Block From To Days Stdv.', 3 ' Time lag Bias Used'/ 4 54X,A8,5X,'[s]'/) 17030 FORMAT(6X,I6,2(2X,I8,1X,I6),F8.2,2F10.3,2I5) 17031 FORMAT(/6X,'Total'//6X,I6,2(2X,I8,1X,I6),F8.2) 17032 FORMAT(/6X,'Total number of observations:',2X,I10/) 17033 FORMAT(I8,1X,I6,7F10.3) 17034 FORMAT(/ 1' **************************************************************'/ 2' ***** Sequence error(s) occured during input of data. *****'/ 3' ***** These errors are listed on print file CPROJ.PRN. *****'/ 3' ***** Please check your input data at CPROJ.DAT and *****'/ 4' ***** try again. *****'/ 5' ***** Program ANAYLZE finished the execution. *****'/ 6' ****** (It was not successfull, sorry). *****'/ 7' **************************************************************') 17035 FORMAT(' Program ANALYZE, version ',A11,' Fortran 90.'// 1 6X,'Lowpass filtered observations block no.',I4//) 17036 FORMAT(6X,'Program ANALYZE, version ',A11,' Fortran 90.'// 1 6X,'Highpass filtered observations block no.',I4//) 17037 FORMAT(//6X,'*** Program ANALYZE, version ',A11,' Fortran 90.'/ 2 6X,'*** Execution stopped for this file because data errors'/ 3 6X,'*** exceed the threshold.'/) 17038 FORMAT(6X,'***Separation of group ',A4,' and group ',A4, 1' may be dangerous'/) 17041 FORMAT(6X,'Program ANALYZE, version ',A10,' Fortran 90.'// 1 6X,'Highpass filtered data and residual (last column)'/ 2 6X,'Block no.: ',I5/) 17042 FORMAT(/' Standard deviation: ',F10.3,2X,A8/ 1 ' Degree of freedom: ',I10/ 2 ' Maximum residual: ',F10.3,2X,A8/ 3 ' Maximum correlation: ',F10.3, 4 1X,A10,' with ',A10/ 5 ' Condition number of normal equ. ',F10.3) 17043 FORMAT(/' Adjusted tidal parameters :'// 1' theor. '/ 2' from to wave ampl. ampl.fac. stdv. ph.', 3' lead stdv.'/ 4' [cpd] [cpd] [',A8,'] [deg]', 5' [deg]'/) 17044 FORMAT(/' Standard deviation of weight unit:',F10.3/ 1 ' Degree of freedom: ',I10/ 2 ' Max. correlation: ',F10.3, 3 1X,A10,' with ',A10) 17045 FORMAT(A11,2F10.6,F10.5,F10.4,1X,A4, 1' #adjusted parameter') 17046 FORMAT(5X,2F9.6,1X,A4,F9.4,F10.5,F9.5,2F9.4) 17047 FORMAT(//' ***** Total number of',I5,' data errors exceed given'/ 1' ***** limit of ',F10.4,2X,A6,' in all blocks.'//) 17049 FORMAT(6X,I8,I6,3H...,I8,I6,2X,I8,I6,3H...,I8,I6) 17050 FORMAT(6X,I8,3H...,I8,I6,' blocks. Recorded days in total:',F11.3) 17051 FORMAT(' *** High correlation:',F10.3,1X,A10,1X,A10) 17052 FORMAT(F10.2,5F13.6) 17056 FORMAT(F10.7,F15.6) 17053 FORMAT(6X,'FOURIER-spectrum of residuals'/ 1 6X,'amplitudes in ',A8/ 2 6X,'Frequency',3X,5H+0.00,8X,5H+0.05,8X,5H+0.10,8X,5H+0.15,8X, 3 5H+0.20/ 4 6X,'[deg/hour]'/) 17054 FORMAT(/6X,'Average noise level at frequency bands in ',A8/ 1 6X,'0.1 cpd',F11.6,6X,'1.0 cpd',F11.6,4X,' 2.0 cpd',F11.6/ 2 6X,'3.0 cpd',F11.6,6X,'4.0 cpd',F11.6,4X,'white noise',F11.6// 4' adjusted tidal parameters :'// 5' theor. '/ 6' from to wave ampl. ampl.fac. stdv.', 7' ph. lead stdv.'/ 8' [cpd] [cpd] [',A8,'] [deg]', 9' [deg]'/) 17055 FORMAT(/6X,'Estimation of noise by least squares method.'/ 1 6X,'White noise structure assumed.'/) 17057 FORMAT(6X,'Sampling interval:',F10.0,' s') 17058 FORMAT(/6X,'Adjusted meteorological or hydrological parameters:'// 1 6X,'no. regr.coeff. stdv. parameter unit'/) 17059 FORMAT(6X,I3,2F12.5,2X,A10,2X,A8,'/',A10) 17060 FORMAT(/6X,'Maximum residual in block no. ',I10/ 1 6X,'Date: ',I4,'.',I2,'.',I2,'.',I2,' IS :',F10.3,2X,A8/ 2 6X,'RMS residual is :',F10.3,2X,A8/) 17061 FORMAT(6X,'Numerical filter is ',A12,' with ',I4,' coefficients.') 17062 FORMAT(6X,'Pole tide for an elastic earth has been corrected.') 17063 FORMAT(6X,'Gravity variation due to length of day variation', 1' corrected.') 17064 FORMAT(/' ***** You may not use more than',I5,' wavegroups in', 1' this program version.'/ 2' ***** Sorry, you have to modify program ANALYZE.'/ 3' ***** Program ANALYZE stops the execution.'/) 17065 FORMAT(/ 1' ***** You may not use more than',I5,' meteorological', 1' parameters in this program version.'/ 2' ***** Sorry, you have to modify program ANALYZE.'/ 3' ***** Program ANALYZE stops the execution.'/) 17066 FORMAT(/ 1' **********************************************'/ 2' * Program ANALYZE finished the execution *'/ 3' * for project ',A8, ' *'/ 4' * (Hopefully it was successfull). *'/ 5' **********************************************'// 6' Execution time: ',F10.3,' seconds'/) 17067 FORMAT(/ 1' **********************************************'/ 2' * Program ANALYZE finished the execution. *'/ 3' **********************************************'// 4' Total execution time: ',F10.3,' seconds'/) 17069 FORMAT(/ 1' ***** You may not use more than ',I5,' unknowns in this', 1' program version.'/ 2' ***** The current number of unknowns is ',I5/ 3' ***** Sorry, you have to reduce the number of bias parameters'/ 4' ***** or to modify program ANALYZE.'/ 5' ***** Program ANALYZE stops the execution.'/) 17070 FORMAT(8A10) 17071 FORMAT(6X,7A10,A3) 17072 FORMAT(10X,A8) 17075 FORMAT(6X,A22,' TGP, threshold:',D10.3,I10,' waves.') 17076 FORMAT(' *** Number of bias parameters for block ',I5, 1' should not exceed ',I5) 17077 FORMAT(/' Adjusted TSCHEBYSCHEFF polynomial bias', 1' parameters :'// 2 6X,'block degree bias stdv.'//) 17078 FORMAT(2I10,F13.6,1X,A8,F13.6,1X,A8) 17079 FORMAT(6X,'Latitude:',F8.4,' deg, longitude:',F8.4, 1 ' deg, azimuth:',F8.4,' deg.') 17080 FORMAT(6X,'WAHR-DEHANT-ZSCHAU inelastic Earth model used.') 17081 FORMAT(6X,'Rigid Earth model used.') 17082 FORMAT(6X,A5,' window used for least squares adjustment.') 17086 FORMAT(/' Block no. :',I5,' from : ',I8,I6,' to ',I8,I6/ 1' is shorter than the filter length and is thus eliminated.'/) 17087 FORMAT(//6x,'Correlation matrix of meteorological regression', 1' parameters:'// 2 17X,6A10) 17088 FORMAT(/) 17089 FORMAT(6X,A10,1X,6F10.3) 17090 FORMAT(A8,2X,I10) 17091 FORMAT(A8,2X,'C-UNKNOWN ',A8,2X,I10) 17092 FORMAT(A8,2X,'S-UNKNOWN ',A8,2X,I10) 17093 FORMAT(A8,2X,'M-UNKNOWN ',A8,2X,I10) 17094 FORMAT(A8,2X,'B-UNKNOWN ',2I5,I10) 17095 FORMAT(3D26.18) END C BLOCK DATA C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C ! C BLOCK DATA for program ANALYZE, version 1996.03.01 Fortran 90. ! C ! C Routine creation: 19930401 by Hans-Georg Wenzel, ! C Black Forest Observatory, ! C Universitaet Karlsruhe, ! C Englerstr. 7, ! C D-76128 KARLSRUHE, ! C Germany. ! C Tel: 0049-721-6082307, ! C FAX: 0049-721-694552. ! C e-mail: wenzel@gik.bau-verm.uni-karlsruhe.de ! C Last modification: 1996.03.01 by Hans-Georg Wenzel. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPLICIT DOUBLE PRECISION (D) CHARACTER CUNIT(11)*8 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C COMMON /CONST/: To be initialized by BLOCK DATA: ! C DPI: 3.1415.... DPI2: 2.D0*DPI ! C DRAD: DPI/180.D0 DRO: 180.D0/DPI ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! COMMON /CONST/ DPI,DPI2,DRAD,DRO COMMON /UNITS/ CUNIT,IC2 DATA DPI/3.141592653589793D0/,DPI2/6.283185307179586D0/, 1 DRAD/1.745329251994330D-02/,DRO/57.295779513082320D0/ DATA CUNIT/'(m/s)**2','nm/s**2 ',' mas ',' mm ',' mm ', 1' nstr ',' nstr ',' nstr ',' nstr ',' nstr ',' mm '/ END C SUBROUTINE CHOLIN(IUN16,DNV,NU,INV,NSING) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C ! C Routine CHOLIN, version 1996.01.24 Fortran 90. ! C ! C The routine CHOLIN solves a normal equation system and computes ! C the inverse of the normal equation matrix using CHOLESKY's ! C method. Routine CHOLIN is an extended version of routine CHOL ! C written by by R. Forsberg. ! C ! C Input parameter description: ! C ---------------------------- ! C ! C IUN16: Unit number of formatted print file. ! C DNV: vector, in which the upper triangle of the normal ! C equation system to be solved (including the right ! C hand side as last column) has to be stored column- ! C wise before the execution of routine CHOLIN. ! C Right hand side has to be stored starting at ! C DNV(NU*(NU+1)/2+1). In the last element of DNV, ! C the square sum of observations may be stored. ! C After the execution, the solution vector is stored ! C as last column of vector DNV, and the square sum ! C of residuals is stored as last element of DNV. ! C NU: number of unknowns. ! C INV: parameter for computing the inverse of the normal ! C equation matrix. For INV=0, the unknowns will be ! C computed but the inverse of the normal equation ! C matrix will not be computed. This option saves ! C computation time for those cases, where the inverse ! C of the normal equation matrix is not necessary. ! C ! C Output parameter description: ! C ----------------------------- ! C ! C NSING: number of columns of the normal equation system, ! C in which a singulartity has been detected during ! C the CHOLESKY factorization. If NSING is greater ! C zero, the unknwon vector and the inverse of the ! C normal equation matrix may be errorness. ! C ! C Used routines: none ! C -------------- ! C ! C Storage of normal equation system in vector DNV: ! C ------------------------------------------------ ! C ! C The following sketch shows the upper triangle of a normal ! C equation system with 4 unknowns stored in vector DNV. ! C ! C X1 X2 X3 X4 right hand ! C side ! C ! C I DNV( 1) I DNV( 2) I DNV( 4) I DNV( 7) I DNV(11) I ! C I DNV( 3) I DNV( 5) I DNV( 8) I DNV(12) I ! C I DNV( 6) I DNV( 9) I DNV(13) I ! C I DNV(10) I DNV(14) I ! C I DNV(15) I ! C ! C Execution time: ! C --------------- ! C ! C The execution time depends drastically on the number of ! C unknowns, it is about proportional to the third power of NU. ! C The execution time of routine CHOLIN has been measured on the ! C following processors : ! C ! C CY990 : Cyber 990 (CDC2) of RRZN Hannover at August 31., 1987. ! C ! C 486DX2: IBM-AT compatible PC with 66 MHz speed at June 10.,1993.! C MSFOR is Microsoft 5.0 Fortran compiler (real mode), ! C F77L3 is Lahey F77L3 compiler version 5.10 (1993). ! C LF90 is Lahey F90 compiler version 1.10 (1995). ! C PENTIUM: IBM-AT compatible PC with 100 MHz PC-board at Febr. 16, ! C 1996. ! C ! C SPARC2: SUN SPARC2 with 28.5 MIPS, SUN F77 compiler. ! C ! C Execution time for solution only (no inversion): ! C ! C CY990 CY990 CY990 486DX2 486DX2 SPARC 2 ! C FTN FTN VFTN 66 MHz 66 Mhz 28.5 MIPS ! C NU: OL=LOW OL=HIGH VL=HIGH MSFOR LAHEY5 F77L3 ! C ! C 50 0.049 s 0.013 s 0.009 s 0.110 s 0.060 s 0.035 s ! C 100 0.343 s 0.079 s 0.040 s 0.770 s 0.220 s 0.090 s ! C 200 2.546 s 0.544 s 0.192 s 6.090 s 1.650 s 0.637 s ! C 300 8.292 s 1.727 s 0.540 s 20.16 s 5.490 s 2.199 s ! C 400 19.559 s 3.076 s 1.048 s - 13.510 s 5.195 s ! C 500 37.937 s 7.629 s 1.938 s - 26.910 s 10.066 s ! C ! C NU: PENTIUM PENTIUM ! C 100 MHz 100 MHz ! C F77L3 LF90 ! C ! C 50 0.000 s 0.000 s ! C 100 0.060 s 0.000 s ! C 200 0.390 s 0.160 s ! C 300 1.160 s 0.500 s ! C 400 2.860 s 1.380 s ! C 500 5.610 s 2.800 s ! C 1000 46.080 s 24.940 s ! C 2000 - 219.320 s ! C 3000 ! C ! C Execution time for solution and inversion: ! C ! C 486DX2 486DX2 SPARC2 PENTIUM PENTIUM ! C 66 MHz 66 MHz 28.5 MIPS 100 MHz 100 MHz ! C NU: MSFOR F77L3 F77 F77L3 LF90 ! C ! C 50 0.270 s 0.110 s 0.051 s 0.00 s 0.00 s ! C 100 2.370 s 0.550 s 0.258 s 0.11 s 0.11 s ! C 200 18.010 s 4.780 s 2.316 s 1.10 s 0.77 s ! C 300 60.580 s 15.760 s 8.547 s 4.33 s 3.18 s ! C 400 40.700 s 20.820 s 12.30 s 9.84 s ! C 500 83.700 s 42.031 s 26.64 s 22.41 s ! C 1000 - - - - 236.45 s ! C 2000 - - - - s ! C ! C Routine creation: 1985.11.01 by Renee Forsberg, ! C Geodetic Institute, ! C Gamlehave Allee 22, ! C DK-2920 CHARLOTTENLUND, ! C Denmark. ! C Last modification: 1996.01.24 by Hans-Georg Wenzel, ! C Black Forest Observatory, ! C Universitaet Karlsruhe, ! C Englerstr. 7, ! C D-76128 KARLSRUHE, ! C Germany. ! C Tel.: 0721-6082301. ! C FAX: 0721-694552. ! C e-mail: wenzel@gik.bau-verm.uni-karlsruhe.de ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPLICIT DOUBLE PRECISION (D) DOUBLE PRECISION DNV(1) NSING=0 DO 50 NR=1,NU+1 I=NR*(NR-1)/2 IR=I DO 40 NC=1,NR DSUM=0.D0 IC=NC*(NC-1)/2 I=I+1 NC1=NC-1 DO 30 NP=1,NC1 30 DSUM=DSUM-DNV(IR+NP)*DNV(IC+NP) DCI=DNV(I)+DSUM IF(NR.NE.NC) THEN DNV(I)=DCI/DNV(IC+NC) GOTO 40 ENDIF IF(NR.GT.NU) THEN DNV(I)=DCI GOTO 40 ENDIF IF(DCI.GT.0.D0) THEN DNV(I)=DSQRT(DCI) GOTO 40 ENDIF C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Singularity in element no. I: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! NSING=NSING+1 DNV(I)=1.D99 WRITE(IUN16,7001) I,NR,NC 40 CONTINUE 50 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Back substitution: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DO 70 NC=NU,1,-1 I=I-1 IR=I IC=NC*(NC+1)/2 DNV(I)=DNV(I)/DNV(IC) DO 70 NP=NC-1,1,-1 IR=IR-1 IC=IC-1 70 DNV(IR)=DNV(IR)-DNV(I)*DNV(IC) IF(INV.EQ.0) RETURN C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute inverse of the normal equation matrix: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IPIV=NU*(NU+1)/2 IND=IPIV DO 100 I=1,NU DIN=1.D0/DNV(IPIV) DNV(IPIV)=DIN MIN=NU KEND=I-1 LANF=NU-KEND IF(KEND) 140,140,110 110 J=IND DO 120 K=1,KEND DSUM=0.D0 MIN=MIN-1 NR=IPIV NC=J DO 130 L=LANF,MIN NC=NC+1 NR=NR+L 130 DSUM=DSUM+DNV(NC)*DNV(NR) DNV(J)=-DSUM*DIN 120 J=J-MIN 140 IPIV=IPIV-MIN 100 IND=IND-1 DO 180 I=1,NU IPIV=IPIV+I J=IPIV DO 180 K=I,NU DSUM=0.D0 NR=J DO 170 L=K,NU NC=NR+K-I DSUM=DSUM+DNV(NR)*DNV(NC) 170 NR=NR+L DNV(J)=DSUM 180 J=J+K RETURN C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Format statements: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 7001 FORMAT(/' *****warning from routine CHOLIN, version 1996.01.24.'/ 1' *****singularity in element:',I5,' row:',I5,' column:',I5/ 2' *****diagonal element set to 1.D99.'/ 3' *****unknown set to 0.000.'/ 3' *****execution will be continued.'/) END C SUBROUTINE DATUM(IDAT,ITIM,ITY,ITM,ITD,DTH) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C ! C Routine DATUM, version 1997.09.21 Fortran 90. ! C ! C The routine DATUM converts an 8 digit date IDAT and an 6 digit ! C ITIM to year, month, day, hour. ! C ! C Input parameter description: ! C ---------------------------- ! C ! C IDAT: date in 8 digit form. 19930701 means July 1st, 1993.! C ITIM: time in 6 digit form. 131214 means 13 hours, ! C 12 minutes and 14 seconds. ! C ! C Output parameter description: ! C ----------------------------- ! C ! C ITY: INTEGER year. ! C ITM: INTEGER month. ! C ITD: INTEGER day. ! C DTH: DOUBLE PRECISION hour. ! C ! C Routine creation: 19930701 by Hans-Georg Wenzel, ! C Black Forest Observatory, ! C Universitaet Karlsruhe, ! C Englerstr. 7, ! C D-76128 KARLSRUHE 1, ! C Germany. ! C Tel.: 0721-6082301. ! C FAX: 0721-694552. ! C e-mail: wenzel@gik.bau-verm.uni-karlsruhe.de ! C Last Modification: 1997.09.21 by Hans-Georg Wenzel. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPLICIT DOUBLE PRECISION (D) IDATA=IDAT ITY=IDATA/10000 IDATA=IDATA-ITY*10000 ITM=IDATA/100 IDATA=IDATA-ITM*100 ITD=IDATA IDUM=ITIM ITH=IDUM/10000 IDUM=IDUM-ITH*10000 ITMIN=IDUM/100 IDUM=IDUM-ITMIN*100 ITSEC=IDUM DTH=DBLE(ITH)+DBLE(ITMIN)/60.D0+DBLE(ITSEC)/3600.D0 RETURN END C SUBROUTINE ETASTN(IUN16,IPRINT,IMODEL,DLON,DJULD,DUT1,DAS,DASP, 1 DDT) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C ! C Routine ETASTN, version 1996.05.25 Fortran 90. ! C ! C The routine ETASTN computes the astronomical elements for ! C different tidal potential catalogues at a specific epoch, given ! C in UTC. The formulas for the astronomical elements have been ! C taken from Tamura (1987) and Simon et al. (1994). ! C ! C Reference: ! C ---------- ! C ! C Simon, J.L., P. Bretagnon, J. Chapront, M. Chapront-Touze, ! C G. Francou and J. Laskar (1994): Numerical expressions for ! C precession formulae and mean elements for the Moon and the ! C planets. Astronomy and Atsrohysics, vo. 282, 663-683, 1994. ! C Tamura, Y. (1987): A harmonic development of the tide ! C generating potential. Bulletin d'Informations Marees ! C Terrestres vol. 99, 6813-68755, Bruxelles 1987. ! C ! C All variables with D as first character are double precision. ! C ! C Input parameter description: ! C ---------------------------- ! C ! C IUN16: Unit number of formatted printout file. ! C IPRINT: Printout parameter. For IPRINT=0, nothing will ! C be printed on unit IUN16. ! C IMODEL: Parameter describing the tidal potential catalogue. ! C IMODEL = 1: Doodson (1921) catalogue. ! C IMODEL = 2: Cartwright et al. (1973) catalogue. ! C IMODEL = 3: Buellesfeld (1985) catalogue. ! C IMODEL = 4: Tamura (1987) catalogue. ! C IMODEL = 5: Xi (1989) catalogue. ! C IMODEL = 6: Roosbeek (1996) catalogue. ! C IMODEL = 7: Hartmann and Wenzel (1995) catalogue. ! C For IMODEL = 1...5, arguments are computed from ! C Tamura (1987) formulas. For IMODEL = 6 and 7, ! C arguments are computed from Simon et al. (1994) ! C formulas. ! C DJULD: Julian date of the epoch in UTC. ! C ! C Output parameter description: ! C ----------------------------- ! C ! C DAS(1): Mean local Moontime in degree. ! C DAS(2): Mean longitude of the Moon in degree. ! C DAS(3): Mean longitude of the Sun in degree. ! C DAS(4): Mean longitude of the perigee of the Moon's orbit ! C in degree. ! C DAS(5): Negative mean longitude of the ascending node of ! C the Moon's orbit in degree. ! C DAS(6): Mean longitude of the perigee of the Suns's orbit ! C in degree. ! C DAS(7): Mean longitude of the Mercury in degree. ! C DAS(8): Mean longitude of the Venus in degree. ! C DAS(9): Mean longitude of the Mars in degree. ! C DAS(10): Mean longitude of the Jupiter in degree. ! C DAS(11): Mean longitude of the Saturn in degree. ! C ! C DASP(1...11): Time derivatives of the corresponding variables ! C DAS in degree per hour. ! C ! C Used routines: ! C -------------- ! C ETDDTB: interpolates DDT = DTD - UTC from table. ! C ! C Routine creation: 1994.07.30 by Hans-Georg Wenzel, ! C Geodaetisches Institut, ! C Universitaet Karlsruhe, ! C Englerstr. 7, ! C D-76128 KARLSRUHE 1, ! C Germany. ! C Tel.: 0721-6082307, ! C FAX: 0721-694552. ! C e-mail: wenzel@gik.bau-verm.uni-karlsruhe.de ! C Last modification: 1996.05.25 by Hans-Georg Wenzel. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPLICIT DOUBLE PRECISION (D) IMPLICIT INTEGER (I-N) DOUBLE PRECISION DAS(11),DASP(11) SAVE DATA DRAD/0.174532925197721D-001/ D1MD=1.D0/(365250.D0*24.D0) DMJD=DJULD-2400000.5D0 IMJD=DMJD DTH=(DMJD-DBLE(IMJD))*24.D0 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute Universal Time epoch DTUT in Julian Centuries referring ! C to J2000: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DTUT=(DJULD-2451545.0D0)/36525.D0 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Correct DTH to UT1: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DTH=DTH+DUT1/3600.D0 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute epoch DT in Julian Centuries TDB referring to J2000 ! C (1. January 2000 12 h.): ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DT=(DMJD-51544.5D0)/36525.0D0 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Correct time from UTC to TDT: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CALL ETDDTB(IUN16,IPRINT,DJULD,DDT) DT=DT+DDT/3155760000.D0 IF(IPRINT.GT.0) WRITE(IUN16,17001) DMJD DT2=DT*DT DTC1=DT DTC2=DTC1*DTC1 DTC3=DTC2*DTC1 DTC4=DTC3*DTC1 DTM1=DT/10.D0 DTM2=DTM1*DTM1 DTM3=DTM2*DTM1 DTM4=DTM3*DTM1 DTM5=DTM4*DTM1 DTM6=DTM5*DTM1 IF(IMODEL.GE.6) GOTO 2000 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute astronomical elements from TAMURA's 1987 formulas: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DTUT2=DTUT*DTUT DTUT3=DTUT2*DTUT DAL=280.4606184D0 + 36000.7700536D0*DTUT + 0.00038793D0*DTUT2 1 -0.0000000258D0*DTUT3 DALP=(36000.7700536D0 +2.0D0*0.00038793D0*DTUT 1 -3.0D0*0.0000000258D0*DTUT2)/(24.0D0*36525.D0) DS=218.316656D0+481267.881342D0*DT-0.001330D0*DT2 DSP=(481267.881342D0-2.0D0*0.001330D0*DT)/(24.D0*36525.0D0) DH=280.466449D0+36000.769822D0*DT+0.0003036D0*DT2 DHP=(36000.769822D0+2.0D0*0.0003036D0*DT)/(24.D0*36525.0D0) DDS=0.0040D0*DCOS((29.D0+133.0D0*DT)*DRAD) DDSP=(-0.0040D0*133.0D0*DRAD*DSIN((29.D0+133.0D0*DT)*DRAD))/ 1 (24.0D0*36525.0D0) DDH=0.0018D0*DCOS((159.D0+19.D0*DT)*DRAD) DDHP=(-0.0018D0*19.0D0*DRAD*DSIN((159.D0+19.D0*DT)*DRAD))/ 1 (24.0D0*36525.0D0) DAS(1)=DAL-DS+DLON+DTH*15.0D0 DAS(2)=DS+DDS DAS(3)=DH+DDH DAS(4)=83.353243D0 +4069.013711D0*DT -0.010324D0*DT2 DAS(5)=234.955444D0 +1934.136185D0*DT -0.002076D0*DT2 DAS(6)=282.937348D0 + 1.719533D0*DT +0.0004597D0*DT2 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute the speeds in degree per hour: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DASP(1)=DALP-DSP+15.0D0 DASP(2)=DSP+DDSP DASP(3)=DHP+DDHP DASP(4)=(4069.013711D0-2.0D0*0.010324D0*DT)/(24.0D0*36525.0D0) DASP(5)=(1934.136185D0-2.0D0*0.002076D0*DT)/(24.0D0*36525.0D0) DASP(6)=(1.719533D0+2.0D0*0.0004597D0*DT)/(24.0D0*36525.0D0) GOTO 3000 2000 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Mean longitude of the Moon (from Simon et al. 1994): ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DS =218.3166456300D0+481267.8811957500D0*DTC1 2 -0.0014663889D0*DTC2 3 +0.0000018514D0*DTC3 4 -0.0000000153D0*DTC4 DSP=(+481267.8811957500D0 2 -2.D0*0.0014663889D0*DTC1 3 +3.D0*0.0000018514D0*DTC2 4 -4.D0*0.0000000153D0*DTC3)/(36525.D0*24.D0) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Mean longitude of the Sun (from Simon et al. 1994): ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DH=280.46645016D0+ 360007.6974880556D0*DTM1 2 +0.0303222222D0*DTM2 3 +0.0000200000D0*DTM3 4 -0.0000653611D0*DTM4 DHP= (360007.6974880556D0 2 +2.D0*0.0303222222D0*DTM1 3 +3.D0*0.0000200000D0*DTM2 4 -4.D0*0.0000653611D0*DTM3)*D1MD DAS(1) =DH -DS +DLON+DTH*15.0D0 DASP(1)=DHP-DSP+15.0D0 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Modification for Roosbeek (1996) tidal potential catalogue: ! C This modification has been programmed by Roosbeek himself. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(IMODEL.EQ.6) THEN DGMST=280.460618375D0+360007.700536D0*DTM1 2 +0.038793333333D0*DTM2 3 -0.000025833333D0*DTM3 DGMSTP= (360007.700536D0 2 +2.D0*0.038793333333D0*DTM1 3 -3.D0*0.000025833333D0*DTM2)*D1MD DAS(1) =DGMST-DS+DLON+DTH*15.D0 DASP(1)=DGMSTP-DSP+15.D0 ENDIF C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C This correction is necessary because for the determination of ! C the HW95 tidal potential catalogue the difference DDT=TDT-UTC ! C has been neglected. If the GMST would have been computed with ! C with the correct DDT, the effect in GMST would be 1.0027*DDT. ! C This effect is corrected below. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DAS(1)=DAS(1)-0.0027D0*DDT*15.D0/3600.D0 DAS(2) =DS DASP(2)=DSP DAS(3) =DH DASP(3)=DHP C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Mean longitude of lunar perigee (from Simon et al. 1994): ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DAS(4)= 83.35324312D0+40690.1363525000D0*DTM1 2 -1.0321722222D0*DTM2 3 -0.0124916667D0*DTM3 4 +0.0005263333D0*DTM4 DASP(4)= (+40690.1363525000D0 2 -2.D0*1.0321722222D0*DTM1 3 -3.D0*0.0124916667D0*DTM2 4 +4.D0*0.0005263333D0*DTM3)*D1MD C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Negative mean longitude of the ascending node of the Moon ! C in degree (from Simon et al. 1994): ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DAS(5)=234.95544499D0+19341.3626197222D0*DTM1 2 -0.2075611111D0*DTM2 3 -0.0021394444D0*DTM3 4 +0.0001649722D0*DTM4 DASP(5)= (+19341.3626197222D0 2 -2.D0*0.2075611111D0*DTM1 3 -3.D0*0.0021394444D0*DTM2 4 +4.D0*0.0001649722D0*DTM3)*D1MD C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Mean longitude of solar perigee computed from ! C argument no. 2 - D -l': ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DAS(6)=282.93734098D0 +17.1945766666D0*DTM1 1 +0.0456888889D0*DTM2 2 -0.0000177778D0*DTM3 2 -0.0000334444D0*DTM4 DASP(6)= (+17.1945766666D0 1 +2.D0*0.0456888889D0*DTM1 2 -3.D0*0.0000177778D0*DTM2 2 -4.D0*0.0000334444D0*DTM3)*D1MD 3000 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Longitudes of the planets from Simon et al. 1994: ! C Mercury = 7, Venus = 8, Mars = 9, Jupiter = 10, Saturn = 11. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DAS( 7)=252.25090552D0+1494740.7217223248D0*DTM1 2 +0.0303498417D0*DTM2 3 +0.0000181167D0*DTM3 4 -0.0000652778D0*DTM4 5 -0.0000004972D0*DTM5 6 +0.0000000556D0*DTM6 DASP( 7)= (+1494740.7217223248D0 2 +2.D0*0.0303498417D0*DTM1 3 +3.D0*0.0000181167D0*DTM2 4 -4.D0*0.0000652778D0*DTM3 5 -5.D0*0.0000004972D0*DTM4 6 +6.D0*0.0000000556D0*DTM5)*D1MD DAS( 8)=181.97980085D0+ 585192.1295333027D0*DTM1 2 +0.0310139472D0*DTM2 3 +0.0000149111D0*DTM3 4 -0.0000653222D0*DTM4 5 -0.0000004972D0*DTM5 6 +0.0000000556D0*DTM6 DASP( 8)= (+585192.1295333027D0 2 +2.D0*0.0310139472D0*DTM1 3 +3.D0*0.0000149111D0*DTM2 4 -4.D0*0.0000653222D0*DTM3 5 -5.D0*0.0000004972D0*DTM4 6 +6.D0*0.0000000556D0*DTM5)*D1MD DAS( 9)=355.43299958D0+ 191416.9637029695D0*DTM1 2 +0.0310518722D0*DTM2 3 +0.0000156222D0*DTM3 4 -0.0000653222D0*DTM4 5 -0.0000005000D0*DTM5 6 +0.0000000556D0*DTM6 DASP( 9)= (+191416.9637029695D0 2 +2.D0*0.0310518722D0*DTM1 3 +3.D0*0.0000156222D0*DTM2 4 -4.D0*0.0000653222D0*DTM3 5 -5.D0*0.0000005000D0*DTM4 6 +6.D0*0.0000000556D0*DTM5)*D1MD DAS(10)= 34.35151874D0+ 30363.0277484806D0*DTM1 2 +0.0223297222D0*DTM2 3 +0.0000370194D0*DTM3 4 -0.0000523611D0*DTM4 5 +0.0000011417D0*DTM5 6 -0.0000000389D0*DTM6 DASP(10)= (+30363.0277484806D0 2 +2.D0*0.0223297222D0*DTM1 3 +3.D0*0.0000370194D0*DTM2 4 -4.D0*0.0000523611D0*DTM3 5 +5.D0*0.0000011417D0*DTM4 6 -6.D0*0.0000000389D0*DTM5)*D1MD DAS(11)= 50.07744430D0+ 12235.1106862167D0*DTM1 2 +0.0519078250D0*DTM2 3 -0.0000298556D0*DTM3 4 -0.0000972333D0*DTM4 5 -0.0000045278D0*DTM5 6 +0.0000002861D0*DTM6 DASP(11)= (+12235.1106862167D0 2 +2.D0*0.0519078250D0*DTM1 3 -3.D0*0.0000298556D0*DTM2 4 -4.D0*0.0000972333D0*DTM3 5 -5.D0*0.0000045278D0*DTM4 6 +6.D0*0.0000002861D0*DTM5)*D1MD DO 3110 I=1,11 DAS(I)=DMOD(DAS(I),360.0D0) IF(DAS(I).LT.0.D0) DAS(I)=DAS(I)+360.0D0 3110 CONTINUE IF(IPRINT.EQ.0) RETURN C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Print astronomical elements: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! WRITE(IUN16,17004) (DAS(K),DASP(K),K=1,11) C 5000 CONTINUE WRITE(IUN16,17030) RETURN C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Format statements: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 17001 FORMAT(//6x,'Routine ETASTN, version 1996.05.25.'// 1 6x,'Astronomic elements for initial epoch '/ 2 6x,'Modified Julian date (TDT) : ',F15.4/) 17004 FORMAT(// 1 6x,'local Moontime F01',F20.11,' deg F01.',F18.11,' deg/h'/ 2 6x,'lunar longitude F02',F20.11,' deg F02.',F18.11,' deg/h'/ 3 6x,'solar longitude F03',F20.11,' deg F03.',F18.11,' deg/h'/ 4 6x,'lunar perigee F04',F20.11,' deg F04.',F18.11,' deg/h'/ 5 6x,'lunar node longit. F05',F20.11,' deg F05.',F18.11,' deg/h'/ 6 6x,'solar perigee F06',F20.11,' deg F06.',F18.11,' deg/h'/ 7 6x,'longitude Mercury F07',F20.11,' deg F07.',F18.11,' deg/h'/ 8 6x,'longitude Venus F08',F20.11,' deg F08.',F18.11,' deg/h'/ 9 6x,'longitude Mars F09',F20.11,' deg F09.',F18.11,' deg/h'/ . 6x,'longitude Jupiter F10',F20.11,' deg F10.',F18.11,' deg/h'/ 1 6x,'longitude Saturn F11',F20.11,' deg F11.',F18.11,' deg/h'/ 2) 17030 FORMAT(/6x,'***** Routine ETASTN finished the execution.'/) END C SUBROUTINE ETBUFF(NFI,NC,ISTOR,IDAT,ITIM,DCIN,IA,IE) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C ! C Routine ETBUFF, version 1996.03.01 Fortran 90. ! C ! C The routine ETBUFF stores ISTOR data for NC channels in buffer. ! C The maximum number of channels is 9, the maximum number of data ! C per channel is 2596. ! C ! C Input parameter description: ! C ---------------------------- ! C ! C NFI... filter length. NFI is restricted to be less or ! C equal to MAXSTO. ! C NC... number of channels to be used. NC is restricted to ! C be less or equal to MAXNC. ! C ITSTOR... position, at which the new observation vector will ! C be stored. ! C IDAT... date of the new observation, which will be stored ! C in IDSTOR at position ISTOR. ! C ITIM... time of the new observation vector, which will be ! C stored in ITSTOR at position ITSTOR. ! C DCIN... new observation vector(1:MAXNC), which will be ! C stored in array DSTOR at position ISTOR. ! C ! C Output parameter description: ! C ----------------------------- ! C ! C IA: Start index (first position) for the actual NFI ! C elements stored in arrays IDSTOR, ITSTOR, DSTOR. ! C IE: End index (last position) for the actual NFI ! C elements stored in arrays IDSTOR, ITSTOR, DSTOR. ! C ! C COMMON /STORE/: ! C -------------- ! C ! C DSTOR: Array(1:MAXNC,1:MAXSTO), in which the Earth tide ! C and meteorological observations are stored. ! C IDSTOR: Array(1:MAXSTO), in which the date referring to ! C the observations is stored. ! C ITSTOR: Array(1:.MAXSTO), in which the time referring to ! C the observations is stored. ! C ! C Routine creation: 1991.09.21 by Hans-Georg Wenzel, ! C Black Forest Observatory, ! C Universitaet Karlsruhe, ! C Englerstr. 7, ! C D-76128 KARLSRUHE, ! C Germany. ! C Tel.: 0721-6082307, ! C FAX: 0721-694552. ! C e-mail: wenzel@gik.bau-verm.uni-karlsruhe.de ! C Last modification: 1996.03.01 by Hans-Georg Wenzel. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPLICIT DOUBLE PRECISION (D) PARAMETER (MAXNC=9,MAXSTO=2596) DIMENSION DSTOR(MAXNC,MAXSTO),DCIN(MAXNC) DIMENSION ITSTOR(MAXSTO),IDSTOR(MAXSTO) COMMON /STORE/ DSTOR,IDSTOR,ITSTOR ISTOR=ISTOR+1 IF(ISTOR.GT.MAXSTO) GOTO 1000 IDSTOR(ISTOR)=IDAT ITSTOR(ISTOR)=ITIM DO 10 J=1,NC 10 DSTOR(J,ISTOR)=DCIN(J) IE=ISTOR IA=ISTOR-NFI+1 RETURN 1000 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Shift the last NFI elements of arrays IDSTOR, ITSTOR and DSTOR ! C to their beginnings. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DO 1010 I=1,NFI IDSTOR(I)=IDSTOR(MAXSTO-NFI+I) ITSTOR(I)=ITSTOR(MAXSTO-NFI+I) DO 1010 J=1,NC 1010 DSTOR(J,I)=DSTOR(J,MAXSTO-NFI+I) ISTOR=NFI ISTOR=ISTOR+1 IDSTOR(ISTOR)=IDAT ITSTOR(ISTOR)=ITIM DO 1020 J=1,NC 1020 DSTOR(J,ISTOR)=DCIN(J) IE=ISTOR IA=ISTOR-NFI+1 RETURN END C SUBROUTINE ETDDTA(IUN16,IUN27,IPRINT) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C ! C Routine ETDDTA, version 1996.05.29 Fortran 90. ! C ! C The routine ETDDTA reads a table of DDT = ET -UTC or TDT - UTC ! C from file etddt.dat. The file will be opened and after use ! C closed by the routine. ! C ! C The table on file etddt.dat has to be extended, when new data ! C are available. ! C ! C Input parameter description: ! C ---------------------------- ! C ! C IUN16: Unit number of formatted printer unit. ! C IUN27: Unit number of formmated unit, on which the table ! C of DDT has to be stored before the call of routine ! C ETDDTA. This unit will be opened by routine ETDDTA ! C as /home/hwz/eterna34/commdat/etddt.dat ! C IPRINT: Printout parameter. For IPRINT=0, nothing will be ! C written to IUN16. ! C ! C COMMON /DDT/: ! C ------------- ! C DDTTAB: Array (1..3,1..100) containing the table of year, ! C Julian date and DDT. ! C NDDTAB: Number of defined entries in table DDTTAB. ! C ! C Routine creation: 1995.12.20 by Hans-Georg Wenzel, ! C Black Forest Observatory, ! C Universitaet Karlsruhe, ! C Englerstr. 7, ! C D-76128 KARLSRUHE, ! C Germany. ! C Tel.: 0721-6082307, ! C FAX: 0721-694552. ! C e-mail: wenzel@gik.bau-verm.uni-karlsruhe.de ! C Last modification: 1996.05.29 by Hans-Georg Wenzel, ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPLICIT DOUBLE PRECISION (D) IMPLICIT INTEGER (I-N) CHARACTER*10 CTEXT(8),CENDT DOUBLE PRECISION DDTTAB(3,300) COMMON /DDT/ DDTTAB,NDDTAB SAVE DATA CENDT/'C*********'/ C HP-UNIX: OPEN(UNIT=27,FILE='../commdat/etddt.dat',STATUS='OLD') C MS-DOS: OPEN(UNIT=IUN27,FILE='/home/hwz/eterna34/commdat/etddt.dat', 1 STATUS='OLD') 100 READ(IUN27,17001) (CTEXT(I),I=1,8) IF(IPRINT.GT.0) WRITE(IUN16,17002) (CTEXT(I),I=1,8) IF(CTEXT(1).NE.CENDT) GOTO 100 NDDTAB=1 200 READ(IUN27,17003,END=1000) DDTTAB(1,NDDTAB),DDTTAB(2,NDDTAB), 1 DDTTAB(3,NDDTAB) IF(IPRINT.NE.0) THEN WRITE(IUN16,17004) DDTTAB(1,NDDTAB),DDTTAB(2,NDDTAB), 1 DDTTAB(3,NDDTAB) ENDIF NDDTAB=NDDTAB+1 GOTO 200 1000 NDDTAB=NDDTAB-1 CLOSE(IUN27) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Format statements: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 17001 FORMAT(8A10) 17002 FORMAT(1X,7A10,A8) 17003 FORMAT(F15.5,F15.6,F15.3) 17004 FORMAT(F15.5,F15.6,F15.3) RETURN END C SUBROUTINE ETDDTB(IUN16,IPRINT,DTUJD,DDT) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C ! C Routine ETDDTB, version 1996.08.07 Fortran 90. ! C ! C All variables with D as first character are DOUBLE PRECISION. ! C ! C Input parameter description: ! C ---------------------------- ! C ! C IUN16: Formatted printer unit. ! C IPRINT: Printout parameter. For IPRINT=0, nothing will be ! C written on unit IUN16. ! C DTUJD: Julian date of epoch (Universal time). ! C ! C Output parameter description: ! C ----------------------------- ! C ! C DDT: Difference ET - UTC resp. TDT - UTC in seconds ! C from 1955.5 until now. For epochs less 1955.5, DDT ! C is set to 31.59 s. ! C For epochs exceeding the last tabulated epoch, DDT ! C is set to the last tabulated DDT. ! C ET is Ephemeris Time. ! C TDT is Terrestrial Dynamical Time. ! C UTC is Universal Time Coordinated, as broadcasted ! C by radio or GPS satellites. ! C ! C COMMON /DDT/: ! C ------------- ! C ! C DDTTAB: Array (1..3,1..300) containing the table of year, ! C Julian date and DDT. ! C NDDTAB: Number of defined entries in table DDTTAB. ! C ! C Execution time: ! C --------------- ! C ! C 1.38 microsec per call on a 100 MHz Pentium using Lahey LF90 ! C compiler. ! C ! C Routine creation: 1995.12.20 by Hans-Georg Wenzel, ! C Black Forest Observatory, ! C Universitaet Karlsruhe, ! C Englerstr. 7, ! C D-76128 KARLSRUHE, ! C Germany. ! C Tel.: 0721-6082307, ! C FAX: 0721-694552. ! C e-mail: wenzel@gik.bau-verm.uni-karlsruhe.de ! C Last modification: 1996.05.25 by Hans-Georg Wenzel, ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPLICIT DOUBLE PRECISION (D) IMPLICIT INTEGER (I-N) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C COMMON /DDT/: stored table DDTTAB of DDT = TDT - UTC: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DOUBLE PRECISION DDTTAB(3,300) COMMON /DDT/ DDTTAB,NDDTAB SAVE DATA IWARN/1/,ITAB/1/ IF(DTUJD.LT.DDTTAB(2,NDDTAB)) GOTO 100 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C DTUJD exceeds last tabulated epoch DDTTAB(2,NDDTAB). ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DDT=DDTTAB(3,NDDTAB) IF(IWARN.EQ.1) WRITE(IUN16,17003) DDTTAB(1,NDDTAB) IWARN=0 RETURN C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Look at table at position ITAB. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 100 CONTINUE IF(DTUJD.GE.DDTTAB(2,ITAB).AND.DTUJD.LT.DDTTAB(2,ITAB+1)) GOTO 230 IF(DTUJD.LT.DDTTAB(2,ITAB)) THEN ITAB=ITAB-1 IF(ITAB.GT.0) GOTO 100 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Set DDT to first tabulated value and return: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ITAB=1 DDT=DDTTAB(3,1) RETURN ENDIF IF(DTUJD.GT.DDTTAB(2,ITAB+1)) THEN ITAB=ITAB+1 IF(ITAB.LT.NDDTAB) GOTO 100 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Set DDT to last tabulated value and return: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ITAB=NDDTAB DDT=DDTTAB(3,NDDTAB) RETURN ENDIF C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Interpolate table between position ITAB and ITAB+1: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 230 DDT=(DDTTAB(3,ITAB+1)*(DTUJD-DDTTAB(2,ITAB))-DDTTAB(3,ITAB)* 1 (DTUJD-DDTTAB(2,ITAB+1)))/(DDTTAB(2,ITAB+1)-DDTTAB(2,ITAB)) RETURN C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Format statements: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 17001 FORMAT(//6x,'Routine ETDDTB.FOR, version 1996.08.07.'// 1 6x,' List of tables:'// 2 6x,' No. Juld DTX DTY'//) 17002 FORMAT(6X,I10,2F15.5,F10.3) 17003 FORMAT(/ 1 6x,'***** Warning from routine ETDDTB.FOR, version 1996.08.07.'/ 2 6x,'***** Epoch exceeds the last tabulated value:',F10.5/ 3 6x,'***** DDT of last tabulated epoch is used.'/ 4 6x,'***** Please try to update tabels in file etddt.dat.'/) END C SUBROUTINE ETERIN(IUN15,IUN16,IPRINT) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C ! C Routine ETERIN, version 1997.09.21 Fortran 90. ! C ! C The routine reads the control parameter file *.INI for program ! C ANALYZE and returns the control parameters via ! C COMMON /CONTROL3/ and /CONTROL4/. ! C ! C ! C Description of COMMON block /CONTROL3/: ! C --------------------------------------- ! C ! C DDTSEC: sampling interval in seconds. ! C DLAT: stations latitude in degree, referring to WGS84. ! C DLON: stations longitude in degree, positiv east of ! C greenwich, referring to WGS84. ! C DH: ellipsoidal height of the station in meter ! C referring to WGS84. ! C DGRAV: gravity of the station in m/s**2 (necessary for ! C tidal tilt only). ! C DAZ: azimuth of the earth tide sensor in degree (only ! C for tilt and horizontal strain). ! C ITY: year of the initial epoch. ! C ITM: month of the initial epoch. ! C ITD: day of the initial epoch. ! C ITH: hour (UTC) of the initial epoch. ! C IC: earth tide component. ! C IMODEL: tidal potential development. ! C DLIMS: limit for step detection. ! C DLIME: limit for spike detection. ! C NGR: number of wave groups. ! C DFRA: lowest frequency within wave group in deg/h. ! C DFRE: highest frequency within wave group in deg/h. ! C DFTFD: gain of instrumental frequency transfer function. ! C DFTFP: phase lag in degree of instrumental frequency ! C transfer function. ! C ! C ! C Description of COMMON block /CONTROL4/: ! C --------------------------------------- ! C ! C CINST: Earth tide sensor name (CHARACTER*10) ! C CNSY: C CHEAD: C CFILENLF: File name for numerical lowpass filter ! C (CHARACTER*12). ! C ! C Program creation: 1994.11.01 by Hans-Georg Wenzel, ! C Black Forest Observatory, ! C Universitaet Karlsruhe, ! C Englerstr. 7, ! C D-76128 KARLSRUHE 1. ! C Tel.: 0721-6082301. ! C FAX: 0721-694552. ! C e-mail: wenzel@gik.bau-verm.uni-karlsruhe.de ! C Last Modification: 1997.09.21 by Hans-Georg Wenzel. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPLICIT DOUBLE PRECISION (D) CHARACTER CINPUT*75 CHARACTER CINTERN*50 CHARACTER CONTROL*10,CREST*64 CHARACTER CINST*10,CFILENLF*12 CHARACTER CHEAD(10)*64,CBLANK*64 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C The following dimension statement is concerning the number of ! C meteorological parameters, which is 8 in the current program ! C version. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! PARAMETER (MAXNF=8) INTEGER IREG(MAXNF) DOUBLE PRECISION DMECOR(MAXNF) CHARACTER CFY1(MAXNF)*10,CFY2(MAXNF)*10 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C The following dimension statements are concerning the number of ! C wavegroups to be used, which is 85 in the current program ! C version (parameter MAXWG). ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! PARAMETER (MAXWG=85) DIMENSION DFRA(MAXWG),DFRE(MAXWG),DFTFD(MAXWG),DFTFP(MAXWG) CHARACTER CNSY(MAXWG)*4 COMMON /CONTROL3/ DDTSEC,DLAT,DLON,DH,DGRAV,DAZ,DFRA,DFRE,DFTFD, 1 DFTFP,DATLIM,DAMIN,DMECOR COMMON /CONTROL4/ IC,IR,ITYI,ITMI,ITDI,ITHI,IDA,KFILT,IPROBS, 1 IPRLF,IMODEL,IRIGID,IHANN,IQUICK,DPOLTC,DLODTC,IPOLTR,ISTNEQ, 2 NGR,NF,IREG,CFY1,CFY2,CINST,CNSY,CHEAD,CFILENLF CBLANK=' '// 1' ' WRITE(IUN16,17001) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Define default parameters: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DDTSEC=3600.D0 DAZ = 0.D0 DLAT = 0.D0 DLON = 0.D0 DH = 0.D0 DGRAV = 0.D0 IC = 0 ITYI = 1995 ITMI = 1 ITDI = 1 ITHI = 12 IR = 0 IPROBS= 0 IPRLF = 0 IRIGID= 0 IHANN = 0 IQUICK= 0 DPOLTC= 0.0D0 IPOLTR= 0 DLODTC= 0.0D0 ISTNEQ= 0 C IH = 1 IGR = 0 IF = 0 ITHI=0 DO 10 I=1,10 10 CHEAD(I)=CBLANK REWIND IUN15 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Read control record: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 100 CONTINUE READ(IUN15,17002,END=5000) CINPUT WRITE(IUN16,17003) CINPUT II=INDEX(CINPUT,'=') IF(II.EQ.0) GOTO 100 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Input record contains an equal sign at position II: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CONTROL=CINPUT(1:II-1) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Search for # in the same record: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! NLE=LEN(CINPUT) INBL=NLE DO 200 I=II+1,NLE IF(CINPUT(I:I).NE.'#') GOTO 200 INBL=I GOTO 210 200 CONTINUE 210 CREST=CINPUT(II+1:INBL-1) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Search for sensor name: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(CONTROL.NE.'SENSORNAME') GOTO 1300 CINST=CREST GOTO 100 1300 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Search for sampling interval: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(CONTROL.NE.'SAMPLERATE') GOTO 1400 WRITE(CINTERN,'(A15)') CREST READ(CINTERN,'(I15)') IREST DDTSEC=DBLE(IREST) GOTO 100 1400 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Search for stations latitude: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(CONTROL.NE.'STATLATITU') GOTO 2400 WRITE(CINTERN,'(A15)') CREST READ(CINTERN,'(F15.4)') DLAT GOTO 100 2400 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Search for stations longitude: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(CONTROL.NE.'STATLONITU') GOTO 2500 WRITE(CINTERN,'(A15)') CREST READ(CINTERN,'(F15.4)') DLON GOTO 100 2500 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Search for stations height: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(CONTROL.NE.'STATELEVAT') GOTO 2600 WRITE(CINTERN,'(A15)') CREST READ(CINTERN,'(F15.4)') DH GOTO 100 2600 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Search for stations gravity: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(CONTROL.NE.'STATGRAVIT') GOTO 2700 WRITE(CINTERN,'(A15)') CREST READ(CINTERN,'(F15.4)') DGRAV GOTO 100 2700 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Search for stations azimuth: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(CONTROL.NE.'STATAZIMUT') GOTO 2800 WRITE(CINTERN,'(A15)') CREST READ(CINTERN,'(F15.4)') DAZ C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Print first part of control parameters: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! NH=IH-1 DO 5010 IH=1,NH 5010 WRITE(IUN16,17007) CHEAD(IH) WRITE(IUN16,17004) CINST,DDTSEC,DLAT,DLON,DH,DGRAV,DAZ GOTO 100 2800 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Search for initial epoch: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(CONTROL.NE.'INITIALEPO') GOTO 2900 WRITE(CINTERN,'(A15)') CREST READ(CINTERN,'(3I5)') ITYI,ITMI,ITDI ITHI=0 GOTO 100 2900 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Search for tidal component: ! C ! C IC... Earth tide component to be computed. ! C IC=-1: tidal potential, geodetic coefficients ! C in m**2/s**2. ! C IC= 0: vertical tidal acceleration (gravity tide), ! C geodetic coefficients in nm/s**2 (positive ! C down). ! C IC= 1: horizontal tidal acceleration (tidal tilt) ! C in azimuth DAZ, geodetic coefficients in ! C mas = arc sec/1000. ! C IC= 2: vertical tidal displacement, geodetic ! C coefficients in mm. ! C IC= 3: horizontal tidal displacement in azimuth ! C DAZ, geodetic coefficients in mm. ! C IC= 4: vertical tidal strain, geodetic coefficients ! C in 10**-9 = nstr. ! C IC= 5: horizontal tidal strain in azimuth DAZ, ! C geodetic coefficients in 10**-9 = nstr. ! C IC= 6: areal tidal strain, geodetic coefficients ! C in 10**-9 = nstr. ! C IC= 7: shear tidal strain, geodetic coefficients ! C in 10**-9 = nstr. ! C IC= 8: volume tidal strain, geodetic coefficients ! C in 10**-9 = nstr. ! C IC= 9: ocean tides, geodetic coefficients in ! C millimeter. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(CONTROL.NE.'TIDALCOMPO') GOTO 3000 WRITE(CINTERN,'(A15)') CREST READ(CINTERN,'(I15)') IC GOTO 100 3000 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Search for tidal potential catalogue: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(CONTROL.NE.'TIDALPOTEN') GOTO 3100 WRITE(CINTERN,'(A15)') CREST READ(CINTERN,'(I15)') IMODEL GOTO 100 3100 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Search for truncation parameter of tidal potential catalogue: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(CONTROL.NE.'AMTRUNCATE') GOTO 3150 WRITE(CINTERN,'(A15)') CREST READ(CINTERN,'(D15.3)') DAMIN GOTO 100 3150 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Search for print parameter of tidal component development: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(CONTROL.NE.'PRINTDEVEL') GOTO 3200 WRITE(CINTERN,'(A15)') CREST READ(CINTERN,'(I15)') IR GOTO 100 3200 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Search for textheader: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(CONTROL.NE.'TEXTHEADER') GOTO 3300 IF(IH.GT.10) GOTO 3300 CHEAD(IH)=CREST IH=IH+1 GOTO 100 3300 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Search for data error search threshold: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(CONTROL.NE.'SEARDATLIM') GOTO 3400 WRITE(CINTERN,'(A15)') CREST READ(CINTERN,'(F15.4)') DATLIM IDA=1 IF(DATLIM.LE.0.D0) IDA=0 GOTO 100 3400 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Search for numerical lowpass filter to be selected: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(CONTROL.NE.'NUMHIGPASS') GOTO 3500 WRITE(CINTERN,'(A15)') CREST READ(CINTERN,'(I15)') KFILT IF(KFILT.GT.0) KFILT=1 GOTO 100 3500 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Search for numerical lowpass filter to be selected: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(CONTROL.NE.'NUMFILNAME') GOTO 3550 WRITE(CINTERN,'(A15)') CREST READ(CINTERN,'(A12)') CFILENLF KFILT=1 GOTO 100 3550 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Search for print parameter for observations: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(CONTROL.NE.'PRINTOBSER') GOTO 3600 WRITE(CINTERN,'(A15)') CREST READ(CINTERN,'(I15)') IPROBS GOTO 100 3600 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Search for print parameter for observations: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(CONTROL.NE.'PRINTLFOBS') GOTO 3700 WRITE(CINTERN,'(A15)') CREST READ(CINTERN,'(I15)') IPRLF GOTO 100 3700 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Search for rigid earth model parameter: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(CONTROL.NE.'RIGIDEARTH') GOTO 3800 WRITE(CINTERN,'(A15)') CREST READ(CINTERN,'(I15)') IRIGID GOTO 100 3800 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Search for Hann-window parameter: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(CONTROL.NE.'HANNWINDOW') GOTO 3900 WRITE(CINTERN,'(A15)') CREST READ(CINTERN,'(I15)') IHANN IF(IHANN.GT.1) IHANN=1 GOTO 100 3900 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Search for quick look adjustment parameter: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(CONTROL.NE.'QUICKLOOKA') GOTO 4000 WRITE(CINTERN,'(A15)') CREST READ(CINTERN,'(I15)') IQUICK GOTO 100 4000 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Search for pole tide correction parameter: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(CONTROL.NE.'POLTIDECOR') GOTO 4100 WRITE(CINTERN,'(A15)') CREST READ(CINTERN,'(F15.5)') DPOLTC GOTO 100 4100 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Search for pole tide regression parameter: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(CONTROL.NE.'POLTIDEREG') GOTO 4200 WRITE(CINTERN,'(A15)') CREST READ(CINTERN,'(I15)') IPOLTR GOTO 100 4200 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Search for length of day tide correction parameter: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(CONTROL.NE.'LODTIDECOR') GOTO 4300 WRITE(CINTERN,'(A15)') CREST READ(CINTERN,'(F15.5)') DLODTC GOTO 100 4300 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Search for storage of normal equation system parameter: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(CONTROL.NE.'STORENEQSY') GOTO 4400 WRITE(CINTERN,'(A15)') CREST READ(CINTERN,'(I15)') ISTNEQ GOTO 100 4400 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Search for tidal parameters: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(CONTROL.NE.'WAVEGROUPI') GOTO 4500 IGR=IGR+1 WRITE(CINTERN,'(A45)') CREST READ(CINTERN,'(4F10.4,1X,A4)') DFRA(IGR),DFRE(IGR),DFTFD(IGR), 1 DFTFP(IGR),CNSY(IGR) GOTO 100 4500 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Search for meteorological parameters: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(CONTROL.NE.'METEOPARAM') GOTO 4600 IF=IF+1 WRITE(CINTERN,'(A45)') CREST READ(CINTERN,'(I10,F10.4,2A10)') IREG(IF),DMECOR(IF),CFY1(IF), 1 CFY2(IF) GOTO 100 4600 CONTINUE GOTO 100 5000 CONTINUE NGR=IGR NF=IF IF(IPOLTR.EQ.1) DPOLTC=0.D0 IF(IPRINT.EQ.0) RETURN C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Print second part of control parameters: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! WRITE(IUN16,17005) IC,IR,ITYI,ITMI,ITDI,ITHI,IMODEL,DAMIN,DATLIM, 1 KFILT,CFILENLF,DPOLTC,IPOLTR,DLODTC,ISTNEQ DO 5020 IGR=1,NGR 5020 WRITE(IUN16,17006) DFRA(IGR),DFRE(IGR),DFTFD(IGR),DFTFP(IGR), 1 CNSY(IGR) WRITE(IUN16,17009) DO 5030 IF=1,NF 5030 WRITE(IUN16,17008) IREG(IF),DMECOR(IF),CFY1(IF),CFY2(IF) WRITE(IUN16,17009) RETURN C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Format statements: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 17001 FORMAT(//6X,'Routine ETERIN, version 1997.09.21 Fortran 90.'/) 17002 FORMAT(A75) 17003 FORMAT(1X,A75) 17004 FORMAT(/ 2 6X,'earth tide sensor name :',A10/ 3 6X,'sample rate',32X,' :',F10.3,' seconds'/ 3 6X,'stations latitude in degree :',F10.4/ 4 6X,'stations longitude in degree :',F10.4/ 5 6X,'stations height in meter :',F10.3/ 6 6X,'stations gravity in m/s**2 :',F10.4/ 7 6X,'stations azimuth from north in degree :',F10.4) 17005 FORMAT( 1 6X,'earth tide component : ',I10/ 2 6X,'print tidal component development (1=yes) : ',I10/ 3 6X,'initial epoch for tidal development : ',I4,3I3/ 4 6X,'tidal potential development : ',I10/ 5 6X,'threshold for tidal potential catalogue : ',D10.3, 6 6X,'m**2/s**2'/ 7 6X,'threshold for data error search : ',F10.3/ 8 6X,'highpass filtering : ',I10/ 9 6X,'numerical lowpass filter selected : ',A12/ * 6X,'amplitude factor for pole tide correction : ',F10.4/ 1 6X,'pole tide regression : ',I10/ 2 6X,'amplitude factor for LOD tide correction : ',F10.4/ 3 6X,'storage of normal equation system : ',I10/) 17006 FORMAT(6X,'wave group : ',2F10.6,2F10.4,1X,A4) 17007 FORMAT(6X,A64) 17008 FORMAT(6X,'meteorological parameter : ',I5,F10.4,2X,A10,1X,A10) 17009 FORMAT(//) END C SUBROUTINE ETFILT(NFI,NFI2,DFIL,NC,IA,IE,IDF,ITF,DFL,DFH) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C ! C Routine ETFILT, version 1996.03.01 Fortran 90. ! C ! C The routine does numerical filtering of the data stored in ! C array DSTOR using a symmetrical numerical FIR lowpass filter. ! C ! C All parameters with D as first character are DOUBLE PRECISION. ! C ! C Input parameter description: ! C ---------------------------- ! C ! C NFI: Number of filter coefficients (filter length). ! C NFI2: Index of central filter coefficient. ! C DFIL: Array of lowpass filter coefficients (1...NFI). ! C ! C Output parameter description: ! C ----------------------------- ! C ! C IDF: INTEGER date of filtered sample. ! C ITF: INTEGER time of filtered sample. ! C DFL: Lowpass filtered observation vector (1:MAXNC). ! C DFH: Highpass filtered observation vector (1:MAXNC). ! C ! C COMMON /STORE/: ! C -------------- ! C ! C DSTOR: Array(1:MAXNC,1:MAXSTO), in which the Earth tide ! C and meteorological observations are stored. ! C IDSTOR: Array(1:MAXSTO), in which the date referring to ! C the observations is stored. ! C ITSTOR: Array(1:MAXTSO), in which the time referring to ! C the observations is stored. ! C ! C Used routines: none. ! C -------------- ! C ! C Routine creation: 1991.06.29 by Hans-Georg Wenzel, ! C Black Forest Observatory, ! C Universitaet Karlsruhe, ! C Englerstr. 7, ! C D-76128 KARLSRUHE, ! C Germany. ! C Tel.: 0721-6082307, ! C FAX: 0721-694552. ! C e-mail: wenzel@gik.bau-verm.uni-karlsruhe.de ! C Last modification: 1996.03.01 by Hans-Georg Wenzel. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPLICIT DOUBLE PRECISION (D) PARAMETER (MAXNC=9,MAXSTO=2596) DIMENSION DFIL(2001),DSTOR(MAXNC,MAXSTO),DFL(MAXNC),DFH(MAXNC) DIMENSION ITSTOR(MAXSTO),IDSTOR(MAXSTO) COMMON /STORE/ DSTOR,IDSTOR,ITSTOR DO 10 J=1,NC 10 DFL(J)=DSTOR(J,IA+NFI2-1)*DFIL(NFI2) DO 20 I=1,NFI2-1 DO 20 J=1,NC 20 DFL(J)=DFL(J)+(DSTOR(J,IA+I-1)+DSTOR(J,IE+1-I))*DFIL(I) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute highpass filtered observations by subtracting the ! C lowpass filtered observation from the original observation: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DO 30 J=1,NC 30 DFH(J)=DSTOR(J,IA+NFI2-1)-DFL(J) IDF=IDSTOR(IA+NFI2-1) ITF=ITSTOR(IA+NFI2-1) RETURN END C SUBROUTINE ETGCON(IUN16,IPRINT,DLAT,DLON,DH,DGRAV,DAZ,IC,DGK,DPK) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C ! C Routine ETGCON, version 1997.03.03 Fortran 90. ! C corrected 2004.02.18 (B.Ducarme) ! C The routine ETGCON computes the geodetic coefficients for ! C the tidal potential developments, Hartmann and Wenzel ! C normalization. ! C ! C All variables with D as first character are DOUBLE PRECISION. ! C ! C Input parameter description: ! C ---------------------------- ! C ! C IUN16: formatted line printer unit. ! C DLAT: ellipsoidal latitude in degree, referring to ! C geodetic reference system GRS80. ! C DLON: ellipsoidal longitude in degree, referring to ! C geodetic reference system GRS80, positiv east of ! C Greenwhich. ! C DH: ellipsoidal height in meter, referring to geodetic ! C reference system GRS80. ! C DGRAV: gravity in m/s**2. If DGRAV less than 9.50 m/s**2, ! C DGRAV will be overwritten by normal gravity ! C referring to geodetic reference system 1980. ! C DAZ: azimuth in degree from north direction counted ! C clockwise (necessary for tidal tilt only). ! C IC: Earth tide component to be computed. ! C IC=-1: tidal potential, geodetic coefficients ! C in m**2/s**2. ! C IC= 0: vertical tidal acceleration (gravity tide), ! C geodetic coefficients in nm/s**2 (positive ! C down). ! C IC= 1: horizontal tidal acceleration (tidal tilt) ! C in azimuth DAZ, geodetic coefficients in ! C mas = arc sec/1000. ! C IC= 2: vertical tidal displacement, geodetic ! C coefficients in mm. ! C IC= 3: horizontal tidal displacement in azimuth ! C DAZ, geodetic coefficients in mm. ! C IC= 4: vertical tidal strain, geodetic coefficients ! C in 10**-9 = nstr. ! C IC= 5: horizontal tidal strain in azimuth DAZ, ! C geodetic coefficients in 10**-9 = nstr. ! C IC= 6: areal tidal strain, geodetic coefficients ! C in 10**-9 = nstr. ! C IC= 7: shear tidal strain, geodetic coefficients ! C in 10**-9 = nstr. ! C IC= 8: volume tidal strain, geodetic coefficients ! C in 10**-9 = nstr. ! C IC= 9: ocean tides, geodetic coefficients in ! C millimeter. ! C ! C Output parameter description: ! C ----------------------------- ! C ! C DGK: array (1...25) of geodetic coefficients. ! C The geodetic coefficient of degree L and order M ! C is stored in DGK(J) with J=L*(L+1)/2+M-2. ! C DPK: array (1...25) of phases in degree. ! C The phase for degree L and order M is stored in ! C DPK(J) with J=L*(L+1)/2+M-2. ! C ! C Used routines: ! C -------------- ! C ! C ETLOVE: computes latitude dependent elastic parameters. ! C ETLEGN: computes fully normalized Legendre functions and their ! C derivatives. ! C ! C Numerical accuracy: ! C ------------------- ! C ! C The routine has been tested under operation system MS-DOS and ! C UNIX in double precision (8 byte words = 15 digits) using ! C different compilers. ! C ! C References: ! C ! C Wilhelm, H. and W. Zuern (1984): Tidal forcing field. ! C In: Landolt-Boernstein, Zahlenwerte und Funktionen aus ! C Naturwissenschaften und Technik, New series, group V, ! C Vol. 2, Geophysics of the Solid Earth, the Moon and the ! C Planets, Berlin 1984. ! C ! C Zuern, W. and H. Wilhelm (1984): Tides of the solid Earth. ! C In: Landolt-Boernstein, Zahlenwerte und Funktionen aus ! C Naturwissenschaften und Technik, New series, group V, Vol. ! C 2, Geophysics of the Solid Earth, the Moon and the Planets,! C Berlin 1984. ! C ! C Routine creation: 1988.01.29 by Hans-Georg Wenzel, ! C Black Forest Observatory, ! C Universitaet Karlsruhe, ! C Englerstr. 7, ! C D-76128 KARLSRUHE, ! C Germany. ! C Tel.: 0721-6082307, ! C FAX: 0721-694552. ! C e-mail: wenzel@gik.bau-verm.uni-karlsruhe.de ! C Last modification: 1997.03.03 by Hans-Georg Wenzel. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPLICIT DOUBLE PRECISION (D) IMPLICIT INTEGER (I-N) CHARACTER CUNIT(11)*8 DOUBLE PRECISION DGK(25),DPK(25),DGX(25),DGY(25),DGZ(25) DOUBLE PRECISION DP0(25),DP1(25) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C COMMON /LOVE/ contains gravimeter factors, LOVE-numbers, SHIDA- ! C numbers and tilt factors for degree 2...4 at latitude DLAT: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DIMENSION DGLAT(12),DHLAT(12),DKLAT(12),DLLAT(12),DTLAT(12) COMMON /LOVE/ DOM0,DOMR,DGLAT,DGR,DHLAT,DHR,DKLAT,DKR,DLLAT,DLR, 1 DTLAT,DTR C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C COMMON /CONST/: To be initialized by BLOCK DATA: ! C DPI: 3.1415.... DPI2: 2.D0*DPI ! C DRAD: DPI/180.D0 DRO: 180.D0/DPI ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! COMMON /CONST/ DPI,DPI2,DRAD,DRO COMMON /UNITS/ CUNIT,IC2 SAVE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Definition of parameters of Geodetic Reference System 1980. ! C DEA is major semi axis in meter. ! C DEE is square of first excentricity (without dimension). ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DATA DEA/6378136.3D0/,DEE/6.69439795140D-3/ IF(IPRINT.GT.0) WRITE(IUN16,17000) DEA,DEE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C DCLAT is cos and DSLAT is sin of ellipsoidal latitude. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DCLAT=DCOS(DLAT*DRAD) DSLAT=DSIN(DLAT*DRAD) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute normal gravity in m/s**2: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(DGRAV.LT.9.50D0) DGRAV=9.78032677D0*(1.D0+0.001931851353D0* 1 DSLAT**2)/DSQRT(1.D0-DEE*DSLAT**2)-0.3086D-5*DH C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute ellipsoidal curvature radius DN in meter. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DN=DEA/DSQRT(1.D0-DEE*DSLAT**2) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute geocentric latitude DPSI in degree: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DPSI=DRO*DATAN(((DN*(1.D0-DEE)+DH)*DSLAT)/((DN+DH)*DCLAT)) DTHET=90.D0-DPSI DCT=DCOS(DTHET*DRAD) DST=DSIN(DTHET*DRAD) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute fully normalized spherical harmonics: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CALL ETLEGN(DCT,DST,LMAX,DP0,DP1) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute geocentric radius DR in meter: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DR=DSQRT((DN+DH)**2*DCLAT**2+(DN*(1.D0-DEE)+DH)**2*DSLAT**2) IF(IPRINT.GT.0) WRITE(IUN16,17001) DLAT,DPSI,DLON,DH,DGRAV,DR,IC, 1 DAZ C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C DGRAV*10.**9:nm/s**2,DRO*3600.*10.**3:radian to mas ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DF=DRO*3.600D-3/DGRAV C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute latitude dependent elastic parameters from Wahr-Dehant- ! C Zschau model: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CALL ETLOVE(IUN16,IPRINT,DLAT,DH) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C DCPSI is cos and DSPSI is sin of geocentric latitude. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DCPSI=DCOS(DPSI*DRAD) DSPSI=DSIN(DPSI*DRAD) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute spherical geodetic coefficients. ! C DGK contains coefficients for potential in m**2/s**2! C DGX contains coefficients for north accelerations in nm/s**2. ! C DGY contains coefficients for east accelerations in nm/s**2. ! C DGZ contains coefficients for vertical accelerations in nm/s**2. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DRDA=DR/DEA DO 10 LI=2,LMAX DRDADL=DRDA**LI DO 10 MI=0,LI J=LI*(LI+1)/2+MI-2 DGK(J)= DRDADL*DP0(J) DGX(J)=-1.D0*DRDADL/DR*DP1(J)*1.D9 DGY(J)= DRDADL*DBLE(MI)/(DR*DST)*DP0(J)*1.D9 DGZ(J)= DRDADL*DBLE(LI)/DR*DP0(J)*1.D9 10 CONTINUE DO 20 I=1,25 20 DPK(I)=0.D0 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute geodetic coefficients for tidal acceleration vector ! C orientated to ellipsoidal coordinate system stored in ! C DGX (north), DGY (east) and DGZ (upwards), all in nm/s**2. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DCDLAT=DCLAT*DCPSI+DSLAT*DSPSI DSDLAT=DSLAT*DCPSI-DCLAT*DSPSI DO 50 I=1,25 DUMMY =DCDLAT*DGX(I)-DSDLAT*DGZ(I) DGZ(I)=(DSDLAT*DGX(I)+DCDLAT*DGZ(I)) DGX(I)=DUMMY 50 CONTINUE IC2=IC+2 DCAZ=DCOS(DAZ*DRAD) DSAZ=DSIN(DAZ*DRAD) GOTO(100,200,300,400,500,600,700,800,900,1000,1100),IC2 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C IC=-1, compute geodetic coefficients for tidal potential. ! C (m**2/s**2). ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 100 CONTINUE GOTO 2000 200 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C IC=0, compute geodetic coefficients for vertical component ! C (gravity tide in nm/s**2). ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DO 210 I=1,25 DGK(I)=DGZ(I) 210 DPK(I)=180.0D0 GOTO 2000 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C IC=1, compute geodetic coefficients for horizontal component ! C (tidal tilt) in azimuth DAZ, in mas. ! C DF:mas/(nm/s**2), DGX(I),DGY(I): nm/s**2 ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 300 CONTINUE DO 310 I=1,12 DGK(I)=DSQRT((DGX(I)*DCAZ)**2+(DGY(I)*DSAZ)**2)*DF DPK(I)=0.D0 IF(DGX(I)*DCAZ.EQ.0.D0.AND.DGY(I)*DSAZ.EQ.0.D0) GOTO 310 DPK(I)=DRO*DATAN2(DGY(I)*DSAZ,DGX(I)*DCAZ) 310 CONTINUE GOTO 2000 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C IC=2, compute geodetic coefficients for vertical displacement ! C in mm. ! C DGK(I):m**2/s**2, DGRAV:m/s**2, 10**3 conversion to mm ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 400 CONTINUE DFAK=1.D3/DGRAV DO 410 I=1,12 DGK(I)=DGK(I)*DHLAT(I)*DFAK 410 DPK(I)=0.0D0 WRITE(IUN16,*) '*****The component',IC,' has never been tested !' GOTO 2000 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C IC=3, compute geodetic coefficients for horizontal displacement ! C in azimuth DAZ in mm. ! C DGRAV*10.**9:nm/s**2,10.**3:conversion to mm (corr. 2004.02.18) ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 500 CONTINUE DFAK=1.D-6*DR/DGRAV DO 510 I=1,12 DGK(I)=DSQRT((DGX(I)*DCAZ)**2+(DGY(I)*DSAZ)**2)*DLLAT(I)*DFAK DPK(I)=0.D0 IF(DGX(I)*DCAZ.EQ.0.D0.AND.DGY(I)*DSAZ.EQ.0.D0) GOTO 510 DPK(I)=DRO*DATAN2(DGY(I)*DSAZ,DGX(I)*DCAZ) 510 CONTINUE WRITE(IUN16,*) '*****The component',IC,' has never been tested !' GOTO 2000 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C IC=4, compute geodetic coefficients for vertical strain at the ! C Earth's deformed surface in 10**-9 units = nstr. ! C We use a spherical approximation for the vertical strain, ! C i.e. eps(rr) , and a POISSON ratio of 0.25 (see ZUERN and ! C WILHELM 1984, p. 282). ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 600 CONTINUE DPOISS=0.25D0 DFAK=1.D9*DPOISS/(DPOISS-1.D0) DO 610 I=1,3 610 DGK(I)=DGK(I)*DFAK*(2.D0*DHLAT(I)-2.D0*3.D0*DLLAT(I))/(DGRAV*DR) DO 620 I=4,7 620 DGK(I)=DGK(I)*DFAK*(2.D0*DHLAT(I)-3.D0*4.D0*DLLAT(I))/(DGRAV*DR) DO 630 I=8,12 630 DGK(I)=DGK(I)*DFAK*(2.D0*DHLAT(I)-4.D0*5.D0*DLLAT(I))/(DGRAV*DR) DO 640 I=1,12 640 DPK(I)=0.0D0 GOTO 2000 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C IC=5, compute geodetic coefficients for horizontal strain ! C in azimuth DAZ, in 10**-9 units. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 700 CONTINUE DTHETA=(90.D0-DPSI)*DRAD DAZR=(DAZ+180.D0)*DRAD DCAZ =DCOS(DAZR) DSAZ =DSIN(DAZR) DSAZ2=DSIN(2.D0*DAZR) DCSTS=-0.5D0*DSIN(2.D0*DAZR) DCT=DSPSI DST=DCPSI DCT2=DCT*DCT DST2=DST*DST DCC2=DCOS(2.D0*DPSI*DRAD) DC2T=-DCC2 DCOTT =1.D0/DTAN(DTHETA) DCOTT2=1.D0/DTAN(2.D0*DTHETA) DFAK=1.D9/(DR*DGRAV) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Real part is stored in DGX, imaginary part is stored in DGY. ! C Formulas were given by Dr. W. Zuern, BFO Schiltach (personal ! C communication) and tested against horizontal strain computed ! C (with lower precision) by program ETIDEL (made by Bilham). ! C Results agreed to 0.3 % and 0.1 degree for most of the waves, ! C except for 2N2 and L2 (deviation of 3 %). ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DGX(1)=(DHLAT(1)-(6.D0*DLLAT(1)*DC2T)/(3.D0*DCT2-1.D0))*DCAZ**2 1 +(DHLAT(1)-(6.D0*DLLAT(1)*DCT2)/(3.D0*DCT2-1.D0))*DSAZ**2 DGY(1)=0.D0 DGX(2)=(DHLAT(2)-4.D0*DLLAT(2))*DCAZ**2+(DHLAT(2)-DLLAT(2)/DST2 1 +2.D0*DLLAT(2)*DCOTT*DCOTT2)*DSAZ**2 DGY(2)=2.D0*DLLAT(2)*(2.D0*DCOTT2-DCOTT)*DCSTS/DST DGX(3)=(DHLAT(3)+2.D0*DLLAT(3)*(DCOTT*DCOTT-1.D0))*DCAZ**2 1 +(DHLAT(3)-4.D0*DLLAT(3)/DST2+2.D0*DLLAT(3)*DCOTT*DCOTT)*DSAZ**2 DGY(3)=4.D0*DLLAT(3)*DCOTT*DCSTS/DST DGX(4)=(DHLAT(4)+DLLAT(4)*(33.D0-45.D0*DCT2)/(5.D0*DCT2-3.D0))* 1 DCAZ**2+(DHLAT(4)-DLLAT(4)*(1.D0+10.D0*DCT2/(5.D0*DCT2-3.D0)))* 2 DSAZ**2 DGY(4)=0.D0 DGX(5)=(DHLAT(5)-DLLAT(5)*(1.D0+10.D0*(1.D0-4.D0*DCT2)/ 1 (1.D0-5.D0*DCT2)))*DCAZ**2+(DHLAT(5)+DLLAT(5)* 2 (DCOTT*DCOTT-1.D0/DST2-10.D0*DCT2/(5.D0*DCT2-1.D0)))*DSAZ**2 DGY(5)=-20.D0*DLLAT(5)*DCT*DCSTS/(5.D0*DCT2-1.D0) DGX(6)=(DHLAT(6)+DLLAT(6)*(2.D0*DCOTT*DCOTT-7.D0))*DCAZ**2 1 +(DHLAT(6)+DLLAT(6)*(2.D0*DCOTT*DCOTT-1.D0-4.D0/DST2))*DSAZ**2 DGY(6)=-4.D0*DLLAT(6)*(DCOTT-1.D0/DCOTT)*DCSTS/DST DGX(7)=(DHLAT(7)+DLLAT(7)*(6.D0*DCOTT*DCOTT-3.D0))*DCAZ**2 1 +(DHLAT(7)+DLLAT(7)*(3.D0*DCOTT*DCOTT-9.D0/DST2))*DSAZ**2 DGY(7)=12.D0*DLLAT(7)*DCOTT*DCSTS/DST DGX(8)=(DHLAT(8)-4.D0*DLLAT(8)*(4.D0-3.D0*(5.D0*DCT2-1.D0)/ 1 (35.D0*DCT2*DCT2-30.D0*DCT2+3.D0)))*DCAZ**2+ 2 (DHLAT(8)-4.D0*DLLAT(8)*(1.D0+3.D0*(5.D0*DCT2-1.D0)/ 3 (35.D0*DCT2*DCT2-30.D0*DCT2+3.D0)))*DSAZ**2 DGY(8)=0.D0 DGX(9)= (DHLAT(9)-2.D0*DLLAT(9)*(8.D0-3.D0/(7.D0*DCT2-3.D0)))* 1 DCAZ**2+(DHLAT(9)-2.D0*DLLAT(9)*(2.D0+3.D0/(7.D0*DCT2-3.D0)))* 2 DSAZ**2 DGY(9)=DLLAT(9)*3.D0/DCT*(1.D0+2.D0/(7.D0*DCT2-3.D0))*DSAZ2 DGX(10)=(DHLAT(10)-4.D0*DLLAT(10)*(4.D0+3.D0*DCT2/ 1 (7.D0*DCT2**2-8.D0*DCT2+1.D0)))*DCAZ**2 2 +(DHLAT(10)-4.D0*DLLAT(10)*(1.D0-3.D0*DCT2/ 2 (7.D0*DCT2**2-8.D0*DCT2+1.D0)))*DSAZ**2 DGY(10)=-DLLAT(10)*6.D0*DCT/DST**2*(1.D0-4.D0/(7.D0*DCT2-1.D0))* 1 DSAZ2 DGX(11)=(DHLAT(11)-2.D0*DLLAT(11)*(8.D0-3.D0/DST2))*DCAZ**2 1 +(DHLAT(11)-2.D0*DLLAT(11)*(2.D0+3.D0/DST2))*DSAZ**2 DGY(11)= DLLAT(11)*3.D0/DCT*(3.D0-2.D0/DST2)*DSAZ2 DGX(12)=(DHLAT(12)-4.D0*DLLAT(12)*(4.D0-3.D0/DST2))*DCAZ**2 1 +(DHLAT(12)-4.D0*DLLAT(12)*(1.D0+3.D0/DST2))*DSAZ**2 DGY(12)= DLLAT(12)*12.D0*DCT/DST2*DSAZ2 DO 710 I=1,12 DGK(I)=DGK(I)*DSQRT(DGX(I)**2+DGY(I)**2)*DFAK 710 DPK(I)=DPK(I)+DATAN2(DGY(I),DGX(I))*DRO GOTO 2000 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C IC=6, compute geodetic coefficients for areal strain ! C in 10**-9 units = nstr. ! C We use a spherical approximation for the aereal strain, ! C i.e. eps(t,t) + eps(l,l), (see ZUERN and WILHELM 1984, ! C p. 282). ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 800 CONTINUE DO 810 I=1,3 810 DGK(I)=DGK(I)*(2.D0*DHLAT(I)-2.D0*3.D0*DLLAT(I))/(DGRAV*DR)*1.D9 DO 820 I=4,7 820 DGK(I)=DGK(I)*(2.D0*DHLAT(I)-3.D0*4.D0*DLLAT(I))/(DGRAV*DR)*1.D9 DO 830 I=8,12 830 DGK(I)=DGK(I)*(2.D0*DHLAT(I)-4.D0*5.D0*DLLAT(I))/(DGRAV*DR)*1.D9 DO 840 I=1,12 840 DPK(I)=0.0D0 GOTO 2000 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C IC=7, compute geodetic coefficients for shear tidal strain ! C at the Earth's deformed surface in 10**-9 units = nstr. ! C We use a spherical approximation, i.e. eps(t,l) ! C Attention: this component has never been tested !!!! ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 900 CONTINUE DTHETA=(90.D0-DPSI)*DRAD DAZR=(DAZ+180.D0)*DRAD DCAZ =DCOS(DAZR) DSAZ =DSIN(DAZR) DSAZ2=DSIN(2.D0*DAZR) DCSTS=-0.5D0*DSIN(2.D0*DAZR) DCT=DSPSI DST=DCPSI DCT2=DCT*DCT DST2=DST*DST DCC2=DCOS(2.D0*DPSI*DRAD) DC2T=-DCC2 DCOTT =1.D0/DTAN(DTHETA) DCOTT2=1.D0/DTAN(2.D0*DTHETA) DFAK=1.D9/(DR*DGRAV) DGY(1)=0.D0 DGY(2)=2.D0*DLLAT(2)*(2.D0*DCOTT2-DCOTT)*DCSTS/DST DGY(3)=4.D0*DLLAT(3)*DCOTT*DCSTS/DST DGY(4)=0.D0 DGY(5)=-20.D0*DLLAT(5)*DCT*DCSTS/(5.D0*DCT2-1.D0) DGY(6)=-4.D0*DLLAT(6)*(DCOTT-1.D0/DCOTT)*DCSTS/DST DGY(7)=12.D0*DLLAT(7)*DCOTT*DCSTS/DST DGY(8)=0.D0 DGY(9)=DLLAT(9)*3.D0/DCT*(1.D0+2.D0/(7.D0*DCT2-3.D0))*DSAZ2 DGY(10)=-DLLAT(10)*6.D0*DCT/DST**2*(1.D0-4.D0/(7.D0*DCT2-1.D0))* 1 DSAZ2 DGY(11)=DLLAT(11)*3.D0/DCT*(3.D0-2.D0/DST2)*DSAZ2 DGY(12)=DLLAT(12)*12.D0*DCT/DST2*DSAZ2 DO 910 I=1,12 DGK(I)=DGK(I)*DGY(I)*DFAK 910 DPK(I)=0.D0 WRITE(IUN16,*) ' ***** The shear strain has never been tested !' GOTO 2000 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C IC=8, compute geodetic coefficients for volume strain ! C at the Earth's deformed surface in 10**-9 units = nstr. ! C We use a spherical approximation, i.e. eps(t,t)+eps(l,l). ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1000 CONTINUE DPOISS=0.25D0 DFAK=1.D9*(1.D0-2.D0*DPOISS)/(1.D0-DPOISS) DO 1010 I=1,3 1010 DGK(I)=DGK(I)*DFAK*(2.D0*DHLAT(I)-2.D0*3.D0*DLLAT(I))/(DGRAV*DR) DO 1020 I=4,7 1020 DGK(I)=DGK(I)*DFAK*(2.D0*DHLAT(I)-3.D0*4.D0*DLLAT(I))/(DGRAV*DR) DO 1030 I=8,12 1030 DGK(I)=DGK(I)*DFAK*(2.D0*DHLAT(I)-4.D0*5.D0*DLLAT(I))/(DGRAV*DR) DO 1040 I=1,12 1040 DPK(I)=0.0D0 GOTO 2000 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C IC=9, compute geodetic coefficients for static ocean tides in mm.! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1100 CONTINUE DFAK=1.D3/DGRAV DO 1110 I=1,25 DGK(I)=DGK(I)*DFAK 1110 DPK(I)=0.0D0 2000 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Print geodetic coefficients: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(IPRINT.EQ.0) RETURN WRITE(IUN16,17003) IC,DAZ,(DGK(I),CUNIT(IC2),DPK(I),I=1,12) WRITE(IUN16,17004) (DGK(I),CUNIT(IC2),DPK(I),I=13,25) 5000 CONTINUE IF(IPRINT.GT.0) WRITE(IUN16,17005) RETURN C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Format statements: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 17000 FORMAT(' Routine ETGCON, version 1997.03.03.'// 1' Computation of geodetic coefficients'// 3' Parameters of Geodetic Reference System 1980:'/ 4' Major semi axis ',F12.0,' m'/ 5' 1. excentricity ',F12.8/) 17001 FORMAT(' Station parameters:'// 1' Latitude ',F12.6,' deg'/ 2' Geocentric latitude ',F12.6,' deg'/ 3' Longitude ',F12.6,' deg'/ 4' Height ',F12.3,' m'/ 5' Gravity ',F12.6,' m/s**2'/ 6' Geocentric radius ',F12.3,' m'/ 7' Component of observations ',I12/ 8' Azimuth from north direction ',F12.6,' deg'//) 17003 FORMAT(/' Geodetic coefficients and phases for component',I4/ 1' azimuth:',F12.6,' degree'// 2' GC 2,0',F14.8,2X,A8,2X,F14.6,' deg'/ 3' GC 2,1',F14.8,2X,A8,2X,F14.6,' deg'/ 4' GC 2,2',F14.8,2X,A8,2X,F14.6,' deg'/ 5' GC 3,0',F14.8,2X,A8,2X,F14.6,' deg'/ 6' GC 3,1',F14.8,2X,A8,2X,F14.6,' deg'/ 7' GC 3,2',F14.8,2X,A8,2X,F14.6,' deg'/ 8' GC 3,3',F14.8,2X,A8,2X,F14.6,' deg'/ 9' GC 4,0',F14.8,2X,A8,2X,F14.6,' deg'/ *' GC 4,1',F14.8,2X,A8,2X,F14.6,' deg'/ 1' GC 4,2',F14.8,2X,A8,2X,F14.6,' deg'/ 2' GC 4,3',F14.8,2X,A8,2X,F14.6,' deg'/ 3' GC 4,4',F14.8,2X,A8,2X,F14.6,' deg') 17004 FORMAT( 1' GC 5,0',F14.8,2X,A8,2X,F14.6,' deg'/ 2' GC 5,1',F14.8,2X,A8,2X,F14.6,' deg'/ 3' GC 5,2',F14.8,2X,A8,2X,F14.6,' deg'/ 4' GC 5,3',F14.8,2X,A8,2X,F14.6,' deg'/ 5' GC 5,4',F14.8,2X,A8,2X,F14.6,' deg'/ 6' GC 5,5',F14.8,2X,A8,2X,F14.6,' deg'/ 7' GC 6,0',F14.8,2X,A8,2X,F14.6,' deg'/ 8' GC 6,1',F14.8,2X,A8,2X,F14.6,' deg'/ 9' GC 6,2',F14.8,2X,A8,2X,F14.6,' deg'/ *' GC 6,3',F14.8,2X,A8,2X,F14.6,' deg'/ 1' GC 6,4',F14.8,2X,A8,2X,F14.6,' deg'/ 2' GC 6,5',F14.8,2X,A8,2X,F14.6,' deg'/ 3' GC 6,6',F14.8,2X,A8,2X,F14.6,' deg'/) 17005 FORMAT(/6x,'***** Routine ETGCON finished the execution.'/) END C SUBROUTINE ETGREI(ITY,ITM,ITD,DTH) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C ! C Attention: This routine will not correctly work after J2000! ! C Routine ETGREI, version 1997.09.21 Fortran 90. ! C ! C The routine ETGREI computes the GREGORIAN date from year, ! C month, day and hour, where the hour may exceed 24. ! C ! C Input/output parameter description: ! C ----------------------------------- ! C ! C All following parameters are input and output parameters, ! C which measn that the parameters may be changed during ! C the execution of routine ETGREI. ! C ! C ITY: Year in INTEGER form, E.G. 1971 ! C ITM: Month in INTEGER form, E.G. 1 = January. ! C ITD: Day in INTEGER form. ! C DTH: DOUBLE PRECISION hour (UTC). DTH may exceed 24. ! C ! C Routine creation: 1971.05.23 by Hans-Georg Wenzel, ! C Black Forest Observatory, ! C Universitaet Karlsruhe, ! C Englerstr. 7, ! C D-76128 KARLSRUHE 1, ! C Germany. ! C Tel: 0049-721-6082307, ! C FAX: 0049-721-694552. ! C e-mail: wenzel@gik.bau-verm.uni-karlsruhe.de ! C Last modification: 1997.09.21 by Hans-Georg Wenzel. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPLICIT DOUBLE PRECISION (D) IMPLICIT INTEGER (I-N) INTEGER ID1(12),ID2(12) SAVE ID1,ID2 DATA ID1/31,28,31,30,31,30,31,31,30,31,30,31/ DATA ID2/31,29,31,30,31,30,31,31,30,31,30,31/ IH=DTH/24 DTH=DTH-24*IH ITD=ITD+IH 50 L=ITY/4 L=4*L IF(L.EQ.ITY) GOTO 300 100 IF(ITD.LE.ID1(ITM)) GOTO 555 ITD=ITD-ID1(ITM) ITM=ITM+1 IF(ITM.EQ.13) GOTO 200 GOTO 100 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Next year: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 200 ITM=1 ITY=ITY+1 GOTO 50 300 IF(ITD.LE.ID2(ITM)) GOTO 555 ITD=ITD-ID2(ITM) ITM=ITM+1 IF(ITM.EQ.13) GOTO 200 GOTO 300 555 RETURN END C SUBROUTINE ETINPD(IUN15,IUN16,IUN20,IPRINT,NC,DDTSEC,NB,NREC,NERR) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C ! C Routine ETINPD, version 1997.09.20 Fortran 90. ! C ! C The routine ETINPD reads observations from input unit IUN15 and ! C stores them on direct access unit IUN20. ! C ! C Input parameter description: ! C ---------------------------- ! C ! C IUN15: Formatted input data unit. ! C IUN16: Formatted printer unit. ! C IUN20: Unformatted direct access unit. ! C IPRINT: Printout parameter. For IPRINT = 0, noting will be ! C written to printer unit IUN16. ! C NC: Number of data channels (including Earth tide data ! C and meteorological data). NC is restricted to be ! C or equal to 8. ! C DDTSEC: Sampling interval in seconds. ! C ! C Output parameter description: ! C ----------------------------- ! C ! C NB: Number of blocks (uninterrupted parts of data). ! C NB is restricted to be less or equal to 300. ! C NREC: Total number of data records stored on direct ! C access unit IUN20. NREC is not restricted. ! C NERR: Number of sequence errors occured during input of ! C data. ! C ! C Description of COMMON (BLOCKR/: ! C ------------------------------- ! C ! C IRECA: Array(1:MAXNB) of record numbers of first sample of ! C the specific block. ! C IRECE: Array(1:MAXNB) of record numbers of last sample of ! C the specific block. ! C IDATA: Array(1:MAXNB) of start date of the specific block. ! C ITIMA: Array(1:MAXNB) of start time of the specific block. ! C IDATE: Array(1:MAXNB) of end data of the specific block. ! C ITIME: Array(1:MAXNB) of end time of the specific block. ! C ! C Used routines: ! C -------------- ! C ! C ETJULN: Computes Julian date. ! C ! C Program creation: 19930629 by Hans-Georg Wenzel, ! C Black Forest Observatory, ! C Universitaet Karlsruhe, ! C Englerstr. 7, ! C D-76128 KARLSRUHE 1, ! C Germany. ! C Tel.: 0721-6082301. ! C FAX: 0721-694552. ! C e-mail: wenzel@gik.bau-verm.uni-karlsruhe.de ! C Last Modification: 1997.09.20 by Hans-Georg Wenzel. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPLICIT DOUBLE PRECISION (D) CHARACTER C8888*8 PARAMETER (MAXNC=9,MAXNB=300) DIMENSION DCIN(MAXNC),DOFFS(MAXNC) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C The following dimension statements are concerning the number of ! C blocks of data without interruption, which is restricted to ! C MAXNB. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! INTEGER IRECA(MAXNB),IRECE(MAXNB),IDATA(MAXNB),IDATE(MAXNB), 1 ITIMA(MAXNB),ITIME(MAXNB),IOB(MAXNB),NBIAS(MAXNB) DOUBLE PRECISION DSAPR(MAXNB),DSAPO(MAXNB),DTLAG(MAXNB), 1 DMEAN(MAXNC,MAXNB) CHARACTER CINSTR(300)*10 COMMON /BLOCKR/ IRECA,IRECE,IDATA,ITIMA,IDATE,ITIME,IOB,NBIAS, 1 DSAPR,DSAPO,DTLAG,DMEAN COMMON /BLOCKC/ CINSTR DATA C8888/'88888888'/ NB=0 IREC=0 NERR=0 IDTSEC=INT(DDTSEC+0.1D0) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C New block: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 100 CONTINUE IF(NB.GT.0) THEN WRITE(IUN16,17005) NB DO 104 JC=1,NC DMEAN(JC,NB)=DMEAN(JC,NB)/DBLE(IOB(NB)) WRITE(IUN16,17006) JC,DMEAN(JC,NB) 104 CONTINUE ENDIF NB=NB+1 IREC=IREC+1 READ(IUN15,17002,END=1000) CINSTR(NB),DCAL,DSAPR(NB),DTLAG(NB), 1 NBIAS(NB) IF(CINSTR(NB).EQ.C8888) GOTO 1000 IRECA(NB)=IREC IRECE(NB)=IREC DO 105 JC=1,NC 105 DMEAN(JC,NB)=0.D0 READ(IUN15,17000) (DOFFS(J),J=1,NC) READ(IUN15,17001) IDAT,ITIM,(DCIN(J),J=1,NC) DO 110 J=1,NC 110 DCIN(J)=DCIN(J)+DOFFS(J) IF(IPRINT.EQ.0) GOTO 120 WRITE(*,17003) IDAT,ITIM,(DCIN(J),J=1,NC) WRITE(IUN16,17003) IDAT,ITIM,(DCIN(J),J=1,NC) 120 DCIN(1)=DCIN(1)*DCAL DO 125 JC=1,NC 125 DMEAN(JC,NB)=DMEAN(JC,NB)+DCIN(JC) WRITE(IUN20,REC=IREC) IDAT,ITIM,(DCIN(J),J=1,NC) IOB(NB)=1 IDATA(NB)=IDAT ITIMA(NB)=ITIM IDATE(NB)=IDAT ITIME(NB)=ITIM C IDUM=IDAT ITY=IDUM/10000 IDUM=IDUM-10000*ITY ITM=IDUM/100 IDUM=IDUM-100*ITM ITD=IDUM C IDUM=ITIM ITH=IDUM/10000 IDUM=IDUM-ITH*10000 ITMIN=IDUM/100 IDUM=IDUM-ITMIN*100 ITSEC=IDUM C DTH=DBLE(ITH)+DBLE(ITMIN)/60.D0+DBLE(ITSEC)/3600.D0 CALL ETJULN(IUN16,ITY,ITM,ITD,DTH,DJULD) DJULDN=DJULD+DBLE(IDTSEC)/(24.D0*3600.D0) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Read rest of the block: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 200 READ(IUN15,17001) IDAT,ITIM,(DCIN(J),J=1,NC) IF(IDAT.EQ.99999999) GOTO 100 IF(IDAT.NE.77777777) GOTO 220 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Step, update offsets: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DO 210 JC=1,NC 210 DOFFS(JC)=DOFFS(JC)+DCIN(JC) GOTO 200 220 CONTINUE C IDUM=IDAT ITY=IDUM/10000 IDUM=IDUM-10000*ITY ITM=IDUM/100 IDUM=IDUM-100*ITM ITD=IDUM C IDUM=ITIM ITH=IDUM/10000 IDUM=IDUM-ITH*10000 ITMIN=IDUM/100 IDUM=IDUM-ITMIN*100 ITSEC=IDUM C DTH=DBLE(ITH)+DBLE(ITMIN)/60.D0+DBLE(ITSEC)/3600.D0 CALL ETJULN(IUN16,ITY,ITM,ITD,DTH,DJULD) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Check the sequence of data: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(DABS(DJULDN-DJULD).LT.1.D-5) GOTO 230 WRITE(*,17004) IDAT,ITIM WRITE(IUN16,17004) IDAT,ITIM NERR=NERR+1 230 CONTINUE DJULDN=DJULD+DBLE(IDTSEC)/(24.D0*3600.D0) DO 250 J=1,NC 250 DCIN(J)=DCIN(J)+DOFFS(J) IF(IPRINT.EQ.0) GOTO 260 WRITE(*,17003) IDAT,ITIM,(DCIN(J),J=1,NC) WRITE(IUN16,17003) IDAT,ITIM,(DCIN(J),J=1,NC) 260 DCIN(1)=DCIN(1)*DCAL DO 265 JC=1,NC 265 DMEAN(JC,NB)=DMEAN(JC,NB)+DCIN(JC) IREC=IREC+1 WRITE(IUN20,REC=IREC) IDAT,ITIM,(DCIN(J),J=1,NC) IOB(NB)=IOB(NB)+1 IRECE(NB)=IREC IDATE(NB)=IDAT ITIME(NB)=ITIM GOTO 200 1000 CONTINUE NB=NB-1 NREC=IREC-1 RETURN C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Format statements: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 17000 FORMAT(15X,8F10.3) 17001 FORMAT(I8,1X,I6,8F10.3) 17002 FORMAT(A10,5X,2F10.4,F10.3,I10) 17003 FORMAT(1X,I8,1X,I6,8F10.3) 17004 FORMAT(' ***** Error of sequence at ',I9,1X,I6) 17005 FORMAT(/' Routine ETINPD, version 1997.09.20'/ 1' average of samples for block: ',I5/ 2' channel average'/) 17006 FORMAT(7X,I10,F10.3) END C SUBROUTINE ETSDER(IUN16,IUN20,JB,NO,NC,DATLIM,NDLB) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C ! C Routine ETSDER, version 1996.08.10 Fortran 90. ! C ! C The routine ETSDER searches for blunders in the earth tide ! C observations of the current block. The data test filter DTF is ! C described in ! C ! C Wenzel, H.-G. (1976): Zur Genauigkeit von gravimetrischen Erd- ! C gezeitenbeobachtungen. Wissenschaftliche Arbeiten ! C der Lehrstuehle fuer Geodaesie, Photogrammetrie ! C und Kartographie an der Technischen Universitaet ! C Hannover Nr. 67, Hannover 1976. ! C ! C All variables with D as first character are DOUBLE PRECISION. ! C ! C Input parameter description: ! C ---------------------------- ! C ! C IUN16: Unit number of formatted printout file. ! C IUN20: Unit number of unformatted direct access file, ! C on which the earth tide observations are stored. ! C JB: Number of current block. ! C NO: Number of earth tide observations in the current ! C block. ! C NC: Number of channels. ! C DATLIM: Date error threshold in units of the earth tide ! C observations. ! C ! C Output parameter description: ! C ----------------------------- ! C ! C NDLB: Number of suspected data errors in the current ! C data block. ! C ! C Used routines: None ! C -------------- ! C ! C Routine creation: 19901230 by Hans-Georg Wenzel, ! C Black Forest Observatory, ! C Universitaet Karlsruhe, ! C Englerstr. 7, ! C D-76128 KARLSRUHE, ! C Germany. ! C Tel: 0049-721-6082307, ! C FAX: 0049-721-694552. ! C e-mail: wenzel@gik.bau-verm.uni-karlsruhe.de ! C Last modification: 1996.08.10 by Hans-Georg Wenzel. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPLICIT DOUBLE PRECISION (D) IMPLICIT INTEGER (I-N) SAVE DOUBLE PRECISION DAL(23),DCIN(9) DOUBLE PRECISION DTF(23) INTEGER IDATS(23),ITIMS(23) C PARAMETER (MAXDE=200) DOUBLE PRECISION DATERR(MAXDE) INTEGER IDATER(MAXDE),ITIMER(MAXDE) C PARAMETER (MAXNB=300) INTEGER IRECA(MAXNB),IRECE(MAXNB),IDATA(MAXNB),ITIMA(MAXNB), 1 IDATE(MAXNB),ITIME(MAXNB),IOB(MAXNB),NBIAS(MAXNB) DOUBLE PRECISION DSAPR(MAXNB),DSAPO(MAXNB),DTLAG(MAXNB) CHARACTER CINSTR(MAXNB)*10 COMMON /BLOCKR/ IRECA,IRECE,IDATA,ITIMA,IDATE,ITIME,IOB,NBIAS, 1 DSAPR,DSAPO,DTLAG COMMON /BLOCKC/ CINSTR C CHARACTER CUNIT(11)*8 COMMON /UNITS/ CUNIT,IC2 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Define coefficients of numerical data test filter with 23 h ! C length, see Wenzel (1976), page XVII. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DATA DTF/ -0.033261D0, 0.070770D0, 0.012603D0,-0.061752D0, 1-0.061916D0, 0.013218D0, 0.093693D0, 0.095321D0,-0.019683D0, 2-0.214064D0,-0.394930D0, 1.000000D0,-0.394930D0,-0.214064D0, 3-0.019683D0, 0.095321D0, 0.093693D0, 0.013218D0,-0.061916D0, 4-0.061752D0, 0.012603D0, 0.070770D0,-0.033261D0/ DATA NFI/23/,NFI2/12/ WRITE(IUN16,17001) JB NDLB=0 DRMS=0.D0 NN=0 ISTAR=IRECA(JB) ISTOP=ISTAR+NFI-1 DO 290 IREC=ISTAR,ISTOP READ(IUN20,REC=IREC) IDAT,ITIM,(DCIN(JC),JC=1,NC) K=IREC-ISTAR+1 DAL(K)=DCIN(1) IDATS(K)=IDAT ITIMS(K)=ITIM 290 CONTINUE IREC=ISTOP 300 DFTEST=0.D0 DO 310 K=1,NFI DFTEST=DFTEST+DTF(K)*DAL(K) 310 CONTINUE IF(DABS(DFTEST).LE.DATLIM) GOTO 260 IF(NDLB.GE.MAXDE) GOTO 260 NDLB=NDLB+1 IDATER(NDLB)=IDATS(NFI2) ITIMER(NDLB)=ITIMS(NFI2) DATERR(NDLB)=DFTEST 260 DRMS=DRMS+DFTEST**2 NN=NN+1 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Shift arrays: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DO 400 K=1,NFI-1 DAL(K)=DAL(K+1) IDATS(K)=IDATS(K+1) 400 ITIMS(K)=ITIMS(K+1) IREC=IREC+1 IF(IREC.GT.IRECE(JB)) GOTO 1000 READ(IUN20,REC=IREC) IDAT,ITIM,(DCIN(JC),JC=1,NC) DAL(NFI)=DCIN(1) IDATS(NFI)=IDAT ITIMS(NFI)=ITIM GOTO 300 1000 CONTINUE DRMS=DSQRT(DRMS/DBLE(NN)) WRITE(IUN16,17002) JB,DRMS,CUNIT(IC2) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Print list of data errors: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! WRITE(IUN16,17003) NDLB,DATLIM,CUNIT(IC2) IF(NDLB.EQ.0) RETURN WRITE(IUN16,17004) DATMAX=0.D0 JMAX=0 DO 1010 J=1,NDLB DTEST=DABS(DATERR(J)) IF(DTEST.LT.DATMAX) GOTO 1010 DATMAX=DTEST JMAX=J 1010 CONTINUE DO 1020 J=1,NDLB IF(J.EQ.JMAX) THEN WRITE(IUN16,17005) IDATER(J),ITIMER(J),DATERR(J) ELSE WRITE(IUN16,17006) IDATER(J),ITIMER(J),DATERR(J) ENDIF 1020 CONTINUE RETURN C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Format statements: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 17001 FORMAT(/6X,'Routine ETSDER version 1996.08.10 Fortran 90.'// 1 6X,'Search for data errors in block no.',I10// 2 6X,'*** There exist better methods for data error search.'/ 3 6X,'*** Before correcting data on the result of this routine,'/ 4 6X,'*** you should apply other methods !!'/) 17002 FORMAT(/6X,'Observation block no. :',I10/ 1 6X,'rms of data errors :',F10.3,2X,A8/) 17003 FORMAT(6X,' *****',I5,' data errors exceed limit of',F10.3,2X,A8/) 17004 FORMAT(/6X,'Date time data error'/) 17005 FORMAT(6X,I8,1X,I6,F10.3,' *** maximum') 17006 FORMAT(6X,I8,1X,I6,F10.3) END C SUBROUTINE ETJULN(IUN16,ITY,ITM,ITD,DTH,DJULD) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C ! C Routine ETJULN, version 1996.05.25 Fortran 90. ! C ! C The routine ETJULN computes the Julian date and the modified ! C Julian date. ETJULN is a modified version of routine MJD given ! C in PASCAL by Montenbruck and Pfleger (see below). ! C ! C The routine is valid for every date since year -4713. ! C Comparison with reference values between years -1410 and +3200 ! C from JPL was successfully. ! C ! C Reference: Montenbruck, O. and T. Pfleger (1989): Astronomie mit ! C dem Personal Computer. Springer Verlag, Berlin 1989. ! C ! C Input parameter description: ! C ---------------------------- ! C ! C ITY: Year (INTEGER). ! C ITM: Month (INTEGER). ! C ITD: Day (INTEGER). ! C DTH: Hour (DOUBLE PRECISION). ! C ! C Output parameter description: ! C ----------------------------- ! C ! C DJULD: Julian date (DOUBLE PRECISION). ! C 16. April -1410, 0.00 H is DJULD = 1206160.5D0 ! C 31. January -1100, 0.00 H is DJULD = 1319312.5D0 ! C 24. January -0800, 0.00 H is DJULD = 1428880.5D0 ! C 17. January -0500, 0.00 H is DJULD = 1538448.5D0 ! C 10. January -0200, 0.00 H is DJULD = 1648016.5D0 ! C 03. January 100, 0.00 H is DJULD = 1757584.5D0 ! C 29. February 400, 0.00 H is DJULD = 1867216.5D0 ! C 20. December 699, 0.00 H is DJULD = 1976720.5D0 ! C 15. February 1000, 0.00 H is DJULD = 2086352.5D0 ! C 08. February 1300, 0.00 H is DJULD = 2195920.5D0 ! C 11. February 1600, 0.00 H is DJULD = 2305488.5D0 ! C 06. February 1900, 0.00 H is DJULD = 2415056.5D0 ! C 01. January 1988, 0.00 H is DJULD = 2447161.5D0 ! C 01. February 1988, 0.00 H is DJULD = 2447192.5D0 ! C 29. February 1988, 0.00 H is DJULD = 2447220.5D0 ! C 01. March 1988, 0.00 H is DJULD = 2447221.5D0 ! C 01. February 2200, 0.00 H is DJULD = 2524624.5D0 ! C 27. January 2500, 0.00 H is DJULD = 2634192.5D0 ! C 23. January 2800, 0.00 H is DJULD = 2743760.5D0 ! C 22. December 3002, 0.00 H is DJULD = 2817872.5D0 ! C ! C To obtain the modified Julian date, subtract 2400000.5 from ! C DJULD. ! C ! C Execution time: ! C --------------- ! C ! C 2.42 microsec per call on a Pentium 100 MHz using Lahex LF90 ! C compiler. ! C ! C Routine creation: 1992.09.19 by Hans-Georg Wenzel, ! C Black Forest Observatory, ! C Universitaet Karlsruhe, ! C Englerstr. 7, ! C D-76128 KARLSRUHE, ! C Germany. ! C Tel.: 0721-6082301. ! C FAX: 0721-694552. ! C e-mail: wenzel@gik.bau-verm.uni-karlsruhe.de ! C Last modification: 1996.05.25 by Hans-Georg Wenzel. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPLICIT DOUBLE PRECISION (D) SAVE ITYY=ITY IF(ITM.LT.1) GOTO 5000 IF(ITM.GT.12) GOTO 5010 ITMM=ITM DA=10000.0D0*ITYY+100.0D0*ITMM+ITD IF(ITMM.LE.2) THEN ITMM=ITMM+12 ITYY=ITYY-1 ENDIF IF(DA.LE.15821004.1D0) THEN DB=-2+(ITYY+4716)/4-1179 ELSE DB=ITYY/400-ITYY/100+ITYY/4 ENDIF DA=365.0D0*DBLE(ITYY)-679004.0D0 DJULD=DA+DB+INT(30.6001D0*(ITMM+1))+DBLE(ITD)+DTH/24.D0 1 +2400000.5D0 RETURN 5000 WRITE(IUN16,17050) ITY,ITM,ITD,DTH STOP 5010 WRITE(IUN16,17051) ITY,ITM,ITD,DTH STOP C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Format statements: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 17050 FORMAT(/' *****Error in routine ETJULN, version 1996.05.25.'/ 1' *****Month is less 1:',2X,3I4,F12.3/ 2' *****Routine ETJULN stops the execution.'/) 17051 FORMAT(/' *****Error in routine ETJULN, version 1996.05.25.'/ 1' *****Month is greater 12:',2X,3I4,F12.3/ 2' *****Routine ETJULN stops the execution.'/) END C SUBROUTINE ETLEGN(DCT,DST,LMAX,DP0,DP1) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C ! C Routine ETLEGN, version 1996.03.11 Fortran 90. ! C ! C The routine computes the fully normalized Legendre functions ! C and their derivatives complete to degree and order 6 by explicit ! C formulas. ! C ! C Input parameter description: ! C ---------------------------- ! C ! C DCT : DOUBLE PRECISION COS of polar distance theta, for ! C which the fully normalized associated Legendre ! C functions will be computed. ! C DST : DOUBLE PRECISION SIN of polar distance theta, for ! C which the fully normalized associated Legendre ! C functions will be computed. ! C ! C Output parameter desription: ! C ----------------------------- ! C ! C LMAX : maximum degree and order, for which the fully ! C normalized associated Legendre functions will be ! C computed. LMAX is equal to 6. ! C DP0: DOUBLE PRECISION array of fully normalized Legendre ! C functions. The fully normalized Legendre function ! C of degree L and order M is stored in ! C DP0(J) WITH J=L*(L+1)/2+M+1. ! C DP1: DOUBLE PRECISION array of first derivatives of the ! C fully normalized Legendre functions to polar ! C distance theta. The first derivative of fully ! C normalized Legendre function of degree L and order ! C M is stored in DP1(J) WITH J=L*(L+1)/2+M-2. ! C ! C Example for theta = 30 degree: ! C ! C J L M DP0(L+1,M+1) DP1(L+1,M*1) ! C ! C 1 2 0 1.39754248593737 2.90473750965556 ! C 2 2 1 -1.67705098312484 1.93649167310371 ! C 3 2 2 0.48412291827593 -1.67705098312484 ! C 4 3 0 0.85923294280422 5.45686207907072 ! C 5 3 1 -2.22775461507770 0.35078038001005 ! C 6 3 2 1.10926495933118 -3.20217211436237 ! C 7 3 3 -0.26145625829190 1.35856656995526 ! C 8 4 0 0.07031250000000 7.30708934443120 ! C 9 4 1 -2.31070453947492 -3.55756236768943 ! C 10 4 2 1.78186666957014 -3.63092188706945 ! C 11 4 3 -0.67928328497763 3.13747509950278 ! C 12 4 4 0.13865811991640 -0.96065163430871 ! C 13 5 0 -0.74051002865529 7.19033890096581 ! C 14 5 1 -1.85653752113519 -8.95158333012718 ! C 15 5 2 2.29938478949397 -1.85857059805883 ! C 16 5 3 -1.24653144252643 4.78747153809058 ! C 17 5 4 0.39826512815546 -2.52932326844337 ! C 18 5 5 -0.07271293151948 0.62971245879506 ! C 19 6 0 -1.34856068213155 4.35442243247701 ! C 20 6 1 -0.95021287641141 -14.00557979016896 ! C 21 6 2 2.47470311782905 2.56294916449777 ! C 22 6 3 -1.85592870532597 5.20453026842398 ! C 23 6 4 0.81047568870385 -4.55019988574613 ! C 24 6 5 -0.22704605589841 1.83519142087945 ! C 25 6 6 0.03784100931640 -0.39325530447417 ! C ! C Execution time: ! C --------------- ! C ! C 0.00006 sec per call of ETLEGN on 80486 DX4 100MHZ with NDEG=6. ! C ! C Program creation: 1995.03.23 by Hans-Georg Wenzel, ! C Geodaetisches Institut, ! C Universitaet Karlsruhe, ! C Englerstr. 7, ! C D-76128 KARLSRUHE, ! C Germany. ! C Tel.: 0721-6082301. ! C FAX: 0721-694552. ! C e-mail: wenzel@gik.bau-verm.uni-karlsruhe.de ! C Last modification: 1996.03.11 by Hans-Georg Wenzel. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPLICIT DOUBLE PRECISION (D) DOUBLE PRECISION DP0(25),DP1(25) LMAX=6 DST2=DST*DST DCT2=DCT*DCT DST3=DST2*DST DCT3=DCT2*DCT DST4=DST3*DST DCT4=DCT3*DCT DST5=DST4*DST DCT5=DCT4*DCT DST6=DST5*DST DCT6=DCT5*DCT C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute fully normalized Legendre functions: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Degree 2: DP0(01)= DSQRT(5.D0/4.D0)*(3.D0*DCT2-1.D0) DP0(02)= DSQRT(15.D0)*DCT*DST DP0(03)= DSQRT(15.D0/4.D0)*DST2 C Degree 3: DP0(04)= DSQRT(7.D0/4.D0)*DCT*(5.D0*DCT2-3.D0) DP0(05)= DSQRT(21.D0/8.D0)*DST*(5.D0*DCT2-1.D0) DP0(06)= DSQRT(105.D0/4.D0)*DST2*DCT DP0(07)= DSQRT(35.D0/8.D0)*DST3 C Degree 4: DP0(08)= 3.D0/8.D0*(3.D0-30.D0*DCT2+35.D0*DCT4) DP0(09)= DSQRT(45.D0/8.D0)*DST*DCT*(7.D0*DCT2-3.D0) DP0(10)= DSQRT(45.D0/16.D0)*(-1.D0+8.D0*DCT2-7.D0*DCT4) DP0(11)= DSQRT(315.D0/8.D0)*DST3*DCT DP0(12)= DSQRT(315.D0/64.D0)*DST4 C Degree 5: DP0(13)= DSQRT(11.D0/64.D0)*DCT*(15.D0-70.D0*DCT2+63.D0*DCT4) DP0(14)= DSQRT(165.D0/64.D0)*DST*(1.D0-14.D0*DCT2+21.D0*DCT4) DP0(15)= DSQRT(1155.D0/16.D0)*DCT*(-1.D0+4.D0*DCT2-3.D0*DCT4) DP0(16)= DSQRT(385.D0/128.D0)*DST3*(9.D0*DCT2-1.D0) DP0(17)= DSQRT(3465.D0/64.D0)*DCT*DST4 DP0(18)= DSQRT(693.D0/128.D0)*DST5 C Degree 6: DP0(19)= DSQRT(13.D0/256.D0)*(-5.D0+105.D0*DCT2-315.D0*DCT4 1 +231.D0*DCT6) DP0(20)= DSQRT(273.D0/64.D0)*DST*DCT*(5.D0-30.D0*DCT2 1 +33.D0*DCT4) DP0(21)= DSQRT(2730.D0/1024.D0)*(1.D0-19.D0*DCT2+51.D0*DCT4 1 -33.D0*DCT6) DP0(22)= DSQRT(2730.D0/256.D0)*DST3*DCT*(-3.D0+11.D0*DCT2) DP0(23)= DSQRT(819.D0/256.D0)*(-1.D0+13.D0*DCT2-23.D0*DCT4 1 +11.D0*DCT6) DP0(24)= DSQRT(18018.D0/256.D0)*DST5*DCT DP0(25)= DSQRT(6006.D0/1024.D0)*DST6 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute derivations with respect to theta: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Degree 2: DP1(01)=-DSQRT(45.D0)*DST*DCT DP1(02)= DSQRT(15.D0)*(1.D0-2.D0*DST2) DP1(03)= DSQRT(15.D0)*DST*DCT C Degree 3: DP1(04)=-DSQRT(63.D0/4.D0)*DST*(5.D0*DCT2-1.D0) DP1(05)= DSQRT(21.D0/8.D0)*DCT*(4.D0-15.D0*DST2) DP1(06)=-DSQRT(105.D0/4.D0)*DST*(1.D0-3.D0*DCT2) DP1(07)= DSQRT(315.D0/8.D0)*DST2*DCT C Degree 4: DP1(08)=-15.D0/2.D0*(7.D0*DCT2-3.D0)*DST*DCT DP1(09)= DSQRT(45.D0/8.D0)*(3.D0-27.D0*DCT2+28.D0*DCT4) DP1(10)=-DSQRT(45.D0)*(4.D0-7.D0*DCT2)*DST*DCT DP1(11)= DSQRT(315.D0/8.D0)*DST2*(4.D0*DCT2-1.D0) DP1(12)= DSQRT(315.D0/4.D0)*DST3*DCT C Degree 5: DP1(13)=-DSQRT(2475.D0/64.D0)*DST*(1.D0-14.D0*DCT2+21.D0*DCT4) DP1(14)= DSQRT(165.D0/64.D0)*DCT*(29.D0-126.D0*DCT2 1 +105.D0*DCT4) DP1(15)=-DSQRT(1155.D0/16.D0)*DST*(-1.D0+12.D0*DCT2-15.D0*DCT4) DP1(16)= DSQRT(3465.D0/128.D0)*DST2*DCT*(15.D0*DCT2-7.D0) DP1(17)=-DSQRT(3465.D0/64.D0)*DST*(1.D0-6.D0*DCT2+5.D0*DCT4) DP1(18)= DSQRT(17325.D0/128.D0)*DCT*DST4 C Degree 6: DP1(19)=-DSQRT(5733.D0/64.D0)*DST*DCT*(5.D0-30.D0*DCT2 1 +33.D0*DCT4) DP1(20)=-DSQRT(273.D0/64.D0)*(5.D0-100.D0*DCT2+285.D0*DCT4 1 -198.D0*DCT6) DP1(21)=-DSQRT(1365.D0/128.D0)*DST*DCT*(-19.D0+102.D0*DCT2 1 -99.D0*DCT4) DP1(22)= DSQRT(12285.D0/128.D0)*DST2*(1.D0-15.D0*DCT2 1 +22.D0*DCT4) DP1(23)=-DSQRT(819.D0/64.D0)*DCT*DST*(13.D0-46.D0*DCT2 1 +33.D0*DCT4) DP1(24)= DSQRT(9009.D0/128.D0)*DST4*(6.D0*DCT2-1.D0) DP1(25)= DSQRT(27027.D0/128.D0)*DST5*DCT RETURN END C SUBROUTINE ETLOVE(IUN16,IPRINT,DLAT,DELV) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C ! C Routine ETLOVE, version 1996.05.25 Fortran 90. ! C ! C The routine computes latitude dependent LOVE-numbers DH, DK, ! C SHIDA-numbers DL, gravimeter factors DG and tilt factors DT ! C using the so-called Wahr-Dehant-Zschau model. ! C ! C Body tide amplitude factors for Wahr-Dehant-Zschau model. ! C The NDFW resonance is approximated by ! C ! C G(RES) = GLAT - GR*(DOM - DOM0)/(DOMR - DOM). ! C ! C similar equations hold for the other parameters. ! C ! C Gravimetric amplitude factors, LOVE numbers h and k for degree ! C 0...3 have been taken from Dehant (1987), Table 7, 8 and 9 ! C for an elliptical, uniformly rotating, oceanless Earth with ! C liquid outer core and inelastic mantle (PREM Earth model with ! C inelastic mantle from Zschau) and for the fourth degree from ! C Dehant et. al (1989), Table 6. The resonance factors GR have ! C been computed to fit the difference between body tide amplitude ! C factors at O1 and PSI1 from Dehant (1987), PREM model with ! C elastic mantle (Table 1...3). The NDFW resonance frequency is ! C 15.073729 degree per hour = 1.004915267 CPD UT, taken from ! C Wahr (1981) (because it is not given in Dehant's papers). ! C ! C Input parameter description: ! C ---------------------------- ! C ! C IUN16: formatted line printer unit. ! C IPRINT: printout parameter. For IPRINT=1, the computed ! C Love- and Shida- number s will be printed. ! C DLAT: ellipsoidal latitude in degree. ! C DELV: ellipsoidal height in meter. ! C ! C Description of COMMON /LOVE/: ! C ----------------------------- ! C ! C DOM0: frequency of O1 in degree per hour. ! C DOMR: frequency of the FCN eigenfrequency in degree per ! C hour. ! C DGLAT: array(1..12) containing the gravimetric factors at ! C latitude DLAT. ! C DGR: resonance factor for gravimetric factors. ! C DHLAT: array(1..12) containing the Love-numbers h at ! C latitude DLAT. ! C DHR: resonance factor for the Love-number h(2,1). ! C DKLAT: array(1..12) containing the Love-numbers k at ! C latitude DLAT. ! C DKR: resonance factor for the Love-number k(2,1). ! C DLLAT: array(1..12) containing the Shida-numbers l at ! C latitude DLAT. ! C DLR: resonance factor for the Shida-number l(2,1). ! C DTLAT: array(1..12) containing the tilt factors at ! C latitude DLAT. ! C ! C Reference: ! C ---------- ! C ! C Dehant, V. (1987): Tidal parameters for an inelastic Earth. ! C Physics of the Earth and Planetary Interiors, 49, 97-116, ! C 1987. ! C ! C Wahr, J.M. (1981): Body tides on an elliptical, rotating, ! C elastic and oceanless earth. Geophysical Journal of the Royal ! C Astronomical Society, vol. 64, 677-703, 1981. ! C ! C Zschau, J. and R. Wang (1987): Imperfect elasticity in the ! C Earth's mantle. Implications for earth tides and long period ! C deformations. Proceedings of the 9th International Symposium ! C on Earth Tides, New York 1987, pp. 605-629, editor J.T. Kuo, ! C Schweizerbartsche Verlagsbuchhandlung, Stuttgart 1987. ! C ! C Routine creation: 1993.07.03 by Hans-Georg Wenzel, ! C Black Forest Observatory, ! C Universitaet Karlsruhe, ! C Englerstr. 7, ! C D-76128 KARLSRUHE, ! C Germany. ! C Tel: 0049-721-6082307, ! C FAX: 0049-721-694552. ! C e-mail: wenzel@gik.bau-verm.uni-karlsruhe.de ! C Last modification: 1996.05.25 by Hans-Georg Wenzel. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPLICIT DOUBLE PRECISION (D) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C The following DIMENSION statement is concerning the elastic ! C Earth model for the different degree and order constituents. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DOUBLE PRECISION DG0(12),DGP(12),DGM(12) DOUBLE PRECISION DH0(12),DHP(12),DHM(12) DOUBLE PRECISION DK0(12),DKP(12),DKM(12) DOUBLE PRECISION DL0(12),DLP(12),DLM(12) DOUBLE PRECISION DLATP(12),DLATM(12) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C COMMON /LOVE/ contains gravimeter factors, Love-numbers, Shida- ! C numbers and tilt factors for degree 2...4 at latitude DLAT: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DIMENSION DGLAT(12),DHLAT(12),DKLAT(12),DLLAT(12),DTLAT(12) COMMON /LOVE/ DOM0,DOMR,DGLAT,DGR,DHLAT,DHR,DKLAT,DKR,DLLAT,DLR, 1 DTLAT,DTR C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C COMMON /CONST/: To be initialized by BLOCK DATA: ! C DPI: 3.1415.... DPI2: 2.D0*DPI ! C DRAD: DPI/180.D0 DRO: 180.D0/DPI ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! COMMON /CONST/ DPI,DPI2,DRAD,DRO SAVE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C The following DATA statements are concerning the elastic ! C Earth model for the different degree and order constituents. ! C The latitude dependency is not given for all constituents in ! C the Wahr-Dehant-Zschau model !!!!!! ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DATA DG0/1.1576D0,1.1542D0,1.1600D0,1.0728D0,1.0728D0,1.0728D0, 1 1.0728D0,1.0363D0,1.0363D0,1.0363D0,1.0363D0,1.0363D0/ DATA DGP/-0.0016D0,-0.0018D0,-0.0010D0,0.D0,0.D0,0.D0,-0.0010D0, 1 0.D0,0.D0,0.D0,0.D0,-0.000315D0/ DATA DGM/0.0054D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, 1 0.D0,0.D0/ DATA DH0/0.6165D0,0.6069D0,0.6133D0,0.2946D0,0.2946D0,0.2946D0, 1 0.2946D0,0.1807D0,0.1807D0,0.1807D0,0.1807D0,0.1807D0/ DATA DHP/0.0007D0,0.0007D0,0.0005D0,0.D0,0.D0,0.D0,0.0003D0, 1 0.D0,0.D0,0.D0,0.D0,0.00015D0/ DATA DHM/0.0018D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, 1 0.D0,0.D0/ DATA DK0/0.3068D0,0.3009D0,0.3034D0,0.0942D0,0.0942D0,0.0942D0, 1 0.0942D0,0.0427D0,0.0427D0,0.0427D0,0.0427D0,0.0427D0/ DATA DKP/0.0015D0,0.0014D0,0.0009D0,0.D0,0.D0,0.D0,0.0007D0, 1 0.D0,0.D0,0.D0,0.D0,0.00066D0/ DATA DKM/-0.0004D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, 1 0.D0,0.D0/ C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Shida-numbers: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DATA DL0/ 0.0840D0,0.0841D0,0.0852D0,0.0149D0,0.0149D0,0.0149D0, 1 0.0149D0,0.0100D0,0.0100D0,0.0100D0,0.0100D0,0.0100D0/ DATA DLP/-0.002D0,-0.002D0,-0.001D0,0.0000D0,0.0000D0,0.0000D0, 1 0.0000D0,0.0000D0,0.0000D0,0.0000D0,0.0000D0,0.0000D0/ DATA DLM/ 0.0000D0,0.0000D0,0.0000D0,0.0000D0,0.0000D0,0.0000D0, 1 0.0000D0,0.0000D0,0.0000D0,0.0000D0,0.0000D0,0.0000D0/ DATA DLATP/0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, 1 0.D0,0.D0/ DATA DLATM/0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, 1 0.D0,0.D0/ C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Definition of parameters of Geodetic Reference System 1980. ! C DEA is major semi axis in meter. ! C DEE is square of first excentricity (without dimnension). ! C DEGM is geocentric gravitational constant in m*3/s**2. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DATA DEA/6378137.00D0/,DEE/6.69438002290D-3/ C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Define resonance frequency and resonance factors: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DOMR=15.073729D0 DOM0=13.943036D0 DGR =-0.000625D0 DHR =-0.002505D0 DKR =-0.001261D0 DLR =0.0000781D0 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C DCLAT is cos and DSLAT is sin of ellipsoidal latitude. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DCLAT=DCOS(DLAT*DRAD) DSLAT=DSIN(DLAT*DRAD) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute ellipsoidal curvature radius DN in meter. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DN=DEA/DSQRT(1.D0-DEE*DSLAT**2) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute geocentric latitude DPSI in degree: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DPSI=DRO*DATAN(((DN*(1.D0-DEE)+DELV)*DSLAT)/((DN+DELV)*DCLAT)) DTHET=90.D0-DPSI DCT=DCOS(DTHET*DRAD) DCT2=DCT*DCT DLATP(1)=0.335410D0*(35.D0*DCT2*DCT2-30.D0*DCT2+3.D0)/ 1 (3.D0*DCT2-1.D0) DLATM(1) =0.894427D0/(3.D0*DCT2-1.D0) DLATP(2) =0.612372D0*(7.D0*DCT2-3.D0) DLATP(3) =0.866025D0*(7.D0*DCT2-1.D0) DLATP(7) =0.829156D0*(9.D0*DCT2-1.D0) DLATP(12)=0.806226D0*(11.D0*DCT2-1.D0) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute latitude dependent gravimeter factors DG: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DO 110 I=1,12 110 DGLAT(I)=DG0(I)+DGP(I)*DLATP(I)+DGM(I)*DLATM(I) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute latitude dependent LOVE-numbers DH (for vertical ! C displacement): ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DO 120 I=1,12 120 DHLAT(I)=DH0(I)+DHP(I)*DLATP(I)+DHM(I)*DLATM(I) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute latitude dependent LOVE-numbers DK: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DO 130 I=1,12 130 DKLAT(I)=DK0(I)+DKP(I)*DLATP(I)+DKM(I)*DLATM(I) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute latitude dependent SHIDA-numbers DL: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DO 140 I=1,12 140 DLLAT(I)=DL0(I)+DLP(I)*DLATP(I)+DLM(I)*DLATM(I) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute latitude dependent tilt factors DT: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DO 150 I=1,12 DTLAT(I)=1.D0+DK0(I)-DH0(I)+DLATP(I)*(DKP(I)-DHP(I))+ 1 DLATM(I)*(DKM(I)-DHM(I)) 150 CONTINUE DTR=DKR-DHR IF(IPRINT.EQ.0) RETURN C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Print out of parameters: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! WRITE(IUN16,17001) DOM0,DOMR,DGR,DHR,DKR,DLR,DTR I=0 WRITE(IUN16,17002) DLAT DO 300 L=2,4 WRITE(IUN16,17004) DO 300 M=0,L I=I+1 WRITE(IUN16,17003) L,M,DGLAT(I),DHLAT(I),DKLAT(I),DLLAT(I), 1 DTLAT(I) 300 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Format statements: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 17001 FORMAT(/6x,'Routine ETLOVE, version 1996.05.25.'/ 1 6x,'Latitude dependent parameters for an elliptical, rotating,'/ 2 6x,'inelastic and oceanless Earth from Wahr-Dehant-Zschau model.' 3 // 4 6x,'frequency of wave O1:',F10.6,' deg per hour'/ 5 6x,'resonance frequency :',F10.6,' deg per hour'// 6 6x,'resonance factor for G:',F10.6/ 7 6x,'resonance factor for h:',F10.6/ 8 6x,'resonance factor for k:',F10.6/ 9 6x,'resonance factor for l:',F10.6/ * 6x,'resonance factor for T:',F10.6/) 17002 FORMAT(// 1 6x,'Latitude dependent elastic parameters'// 2 6x,'ellipsoidal latitude:',F10.4,' deg'// 3 6x,'G is gravimetric factor delta'/ 4 6x,'h is LOVE-number h'/ 5 6x,'k is LOVE-number k'/ 6 6x,'l is SHIDA-number l'/ 7 6x,'T is tilt factor gamma'// 8 6x,'degree order G h k l', 9' T') 17003 FORMAT(6x,2I7,5F10.6) 17004 FORMAT(' ') RETURN END C SUBROUTINE ETLFIN(IUN16,IUN15,IPRINT,CFILENLF,DDTSEC,NFI,DLF, 1 CFILT,IERR) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C ! C Routine ETLFIN, version 1996.08.26 Fortran 90. ! C ! C The routine reads an symmetrical nor-recursive numerical lowpass ! C filter (FIR) to be used within Earth tide analysis program ! C ANALYZE. ! C ! C Input parameter description: ! C ---------------------------- ! C ! C IUN16: Unit number of formatted line printer file. ! C IUN15: Unit number of formatted lowpass filter file. ! C IPRINT: Printout parameter. For IPRINT=0, nothing will be ! C written to unit IUN16. ! C CFILENLF: File name for numewrical lowpass filter. The ! C file CFILEN will be opened by the execution of ! C routine ETLFIN and the numerical lowpass filter ! C will be read from this file. ! C DDTSEC: Sampling interval in sec. ! C ! C Output parameter description: ! C ----------------------------- ! C ! C NFI: Length of filter in hours (number of filter ! C coefficients). ! C DLF: Array of lowpass filter coefficients (1...2001). ! C CFILT: Name of the filter (CHARACTER*12). ! C IERR: Error code. IERR=1, if an error occured during the ! C execution of routine ETLFIN. ! C ! C Numerical accuracy: ! C ------------------- ! C ! C The routine has been tested on an IBM-PC using DOUBLE PRECISION ! C (i.e. 15 digits) for all non-integer variables. ! C ! C Routine creation: 1988.02.18 by Hans-Georg Wenzel, ! C Black Forest Observatory, ! C Universitaet Karlsruhe, ! C Englerstr. 7, ! C D-76128 KARLSRUHE 1, ! C Germany. ! C Tel: 0049-721-6082307, ! C FAX: 0049-721-694552. ! C e-mail: wenzel@gik.bau-verm.uni-karlsruhe.de ! C Last modification: 1996.08.07 by Hans-Georg Wenzel. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPLICIT DOUBLE PRECISION (D) IMPLICIT INTEGER (I-N) DOUBLE PRECISION DLF(2001) CHARACTER CFILENLF*12,CFOLD*12,CFILT*12,CFILE*30 CHARACTER CTEXT(8)*10,CENDT*10 DATA MAXCO/2001/ DATA CENDT/'C*********'/,CFOLD/'xxxxxxxxxxxx'/ IF(CFILENLF.EQ.CFOLD) RETURN CFILE='/home/hwz/eterna34/commdat/' // CFILENLF OPEN(UNIT=IUN15,FILE=CFILE,STATUS='OLD') 100 READ(IUN15,17003) (CTEXT(I),I=1,8) IF(IPRINT.NE.0) WRITE(IUN16,17004) (CTEXT(I),I=1,7) IF(CTEXT(1).NE.CENDT) GOTO 100 READ(IUN15,17005) CFILT READ(IUN15,17006) NFI READ(IUN15,17006) NFI2 READ(IUN15,17007) DDTS READ(IUN15,17007) DDTRESAMP WRITE(IUN16,17001) CFILT,NFI,DDTS IF(NFI.GT.MAXCO) THEN WRITE(IUN16,17009) IERR=1 RETURN ENDIF IF(DABS(DDTS-DDTSEC).GT.1.D0) THEN WRITE(IUN16,17010) WRITE(*,17010) IERR=1 RETURN ENDIF DO 200 I=1,NFI2 READ(IUN15,17008) KFI,DLF(I) DLF(NFI-I+1)=DLF(I) 200 CONTINUE IERR=0 CLOSE(UNIT=IUN15) WRITE(IUN16,17002) RETURN C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Format statements: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 17001 FORMAT(6x,'Routine ETLFIN, version 1996.08.07.'/ 1 6X,'Used numerical filter is ',A12/ 2 6X,'Length of the used numerical filter is ',I10/ 3 6X,'Sampling interval is ',F10.3,' s'/) 17002 FORMAT(6x,'Routine ETLFIN finished the execution.'/) 17003 FORMAT(8A10) 17004 FORMAT(6X,7A10) 17005 FORMAT(10X,A10) 17006 FORMAT(10X,I10) 17007 FORMAT(10X,F10.3) 17008 FORMAT(I8,D24.15) 17009 FORMAT(/ 1 6X,'***Error in routine ETLFIN.'/ 2 6X,'***Filter length exceeds maximum of 2001.'/ 3 6X,'***Routine ETLFIN stops the execution for this project.') 17010 FORMAT(/ 1 6X,'***Error in routine ETLFIN.'/ 2 6X,'***Numerical lowpass filter is not constructed for the ', 3 'sampling interval.'/ 4 6X,'***Routine ETLFIN stops the execution for this project.') END C SUBROUTINE ETPHAS(IUN16,IPRINT,IMODEL,DLON,DJULD) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C ! C Routine ETPHAS, version 1996.08.03 Fortran 90. ! C ! C The routine ETPHAS computes phases and frequencies for the tidal ! C waves using different tidal potential catalogues which use ! C the Hartmann and Wenzel (1995) normalization. ! C ! C All variables with D as first character are DOUBLE PRECISION. ! C ! C Input parameter description: ! C ---------------------------- ! C ! C IUN16: Formatted line printer unit. ! C IPRINT: Printout parameter. ! C for IPRINT = 0, nothing will be printed. ! C for IPRINT = 1, a short list will be printed. ! C for IPRINT = 2, a long list will be printed ! C (including the tidal potential development). ! C IMODEL: Parameter for selecting the tidal potential ! C development. ! C IMODEL = 1: Doodson (1921) tidal potential develop- ! C ment with 378 waves. ! C IMODEL = 2: Cartwright-Taylor-Edden (1973) tidal ! C potential development with 505 waves. ! C IMODEL = 3: Buellesfeld (1985) tidal potential ! C development with 656 waves. ! C IMODEL = 4: Tamura (1987) tidal potential develop- ! C ment with 1200 waves. ! C IMODEL = 5: Xi (1989) tidal potential catalogue ! C 2933 waves. ! C IMODEL = 6: Roosbeek (1995) tidal potential ! C catalogue with ?? waves. ! C IMODEL = 7: Hartmann and Wenzel (1995) tidal ! C potential catalogue with 12935 waves. ! C DLON: Ellipsoidal longitude referring to Geodetic ! C Reference System 1980 in degree, positive east of ! C Greenwhich. ! C DJULD: Julian date of the initial epoch of tidal force ! C development. ! C ! C Output parameter description: ! C ----------------------------- ! C ! C There are no output parameters. The computes phases are trans- ! C to the calling program unit by COMMON /TIDWAVE/. ! C ! C COMMON /TIDWAVE/: contains tidal waves ! C ! C NW: Number of defined tidal waves. ! C IWNR: INTEGER array (1:12935) of wave numbers. ! C IAARG: INTEGER array (1:12935,1:12) of astronomical ! C argument numbers. ! C DX0: DOUBLE PRECISION array (1:12935) of cos-coeffi- ! C cients of the tidal component in units of the tidal ! C component. ! C DX1: DOUBLE PRECISION array (1:12935) of time deriva- ! C tives of cos-coefficients of the tidal component. ! C DY0: DOUBLE PRECISION array (1:12935) of sin-coeffi- ! C cients of the tidal component in units of the tidal ! C component. ! C DY1: DOUBLE PRECISION array (1:12935) of time deriva- ! C tives of sin-coefficients of the tidal component. ! C ! C component unit of unit of ! C IC DX0,DY0 DX1,DY1 ! C -1 m**2/s**2 m**2/s**2 per Julian century ! C 0 nm/s**2 nm/s**2 per Julina century ! C 1 mas mas per Julian century ! C 2 mm mm per Julian century ! C 3 mm mm per Julian century ! C 4 nstr nstr per Julian cenrury ! C 5 nstr nstr per Julian century ! C 6 nstr nstr per Julian century ! C 7 nstr nstr per Julian century ! C 8 nstr nstr per Julian century ! C 9 mm mm per Julian century ! C ! C DTHPH: DOUBLE PRECISION array (1:12935) of tidal phases ! C in radians at initial epoch. ! C DTHFR: DOUBLE PRECISION array (1:12935) of tidal ! C frequencies in radian per hour. ! C DBODY: DOUBLE PRECISION array (1:12935) of body tide ! C amplitude factors for tidal gravity and tidal tilt. ! C In order to compute the body tide, the coefficients ! C DX0, DX1, DY0 and DY1 have to be multiplied by ! C DBODY. ! C ! C Used routines: ! C -------------- ! C ! C ETASTN: computes astronomical elements. ! C ETJULN: computes Julian date. ! C ETDDTA: computes the difference TDT minus UTC (called by ETASTN).! C ETPOLC: computes the difference DUT1 = UT1 - UTC. ! C ! C Numerical accuracy: ! C ------------------- ! C ! C The routine has been tested under operation systems UNIX and ! C MS-DOS with 15 digits in DOUBLE PRECISION. ! C ! C Routine creation: 1988.04.27 by Hans-Georg Wenzel, ! C Black Forest Observatory, ! C Universitaet Karlsruhe, ! C Englerstr. 7, ! C D-76128 KARLSRUHE 1, ! C Germany. ! C Tel: 0049-721-6082307, ! C FAX: 0049-721-694552. ! C e-mail: wenzel@gik.bau-verm.uni-karlsruhe.de ! C Last modification: 1996.08.04 by Hans-Georg Wenzel. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPLICIT DOUBLE PRECISION (D) IMPLICIT INTEGER (I-N) CHARACTER CMODEL(7)*20 DOUBLE PRECISION DAS(11),DASP(11) COMMON /TIDPHAS/ DPK(25) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C The following DIMENSION statement is concerning the number of ! C waves of the tidal potential development, which is 12935. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! COMMON /TIDWAVE/ NW,IWNR(12935),IAARG(12935,12),DX0(12935), 1 DX1(12935),DY0(12935),DY1(12935),DTHPH(12935),DTHFR(12935), 2 DBODY(12935) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C COMMON /CONST/: To be initialized by BLOCK DATA: ! C DPI: 3.1415.... DPI2: 2.D0*DPI ! C DRAD: DPI/180.D0 DRO: 180.D0/DPI ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! COMMON /CONST/ DPI,DPI2,DRAD,DRO SAVE DATA IUN30/30/,IUN31/31/ DATA CMODEL/'Doodson 1921 ', 1 'CTED 1973 ','Buellesfeld 1985 ', 2 'Tamura 1987 ','Xi 1989 ', 3 'Roosbeek 1995 ','Hartmann+Wenzel 1995'/ IF(IPRINT.GT.0) WRITE(IUN16,17001) CMODEL(IMODEL) 1000 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Interpolate DUT1: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CALL ETPOLC(IUN16,IUN30,IUN31,IPRINT,DJULD,DCLAT,DSLAT, 1 DCLON,DSLON,DPOLX,DPOLY,DUT1,DTAI,DLOD,DGPOL,DGPOLP,DGLOD,NERR) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute astronomical elements for initial epoch: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CALL ETASTN(IUN16,IPRINT,IMODEL,DLON,DJULD,DUT1,DAS,DASP,DDT0) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute phases and frequencies: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DO 1110 IW=1,NW DC2=0.D0 DC3=0.D0 DO 1140 J=1,11 DC2=DC2+DBLE(IAARG(IW,J))*DAS(J) 1140 DC3=DC3+DBLE(IAARG(IW,J))*DASP(J) LI=IAARG(IW,12) JCOF=(LI+1)*LI/2-2+IAARG(IW,1) DC2=DC2+DPK(JCOF) 1160 DC2=DMOD(DC2,360.D0) IF(DC2.GE.0.D0) GOTO 1170 DC2=DC2+360.D0 GOTO 1160 1170 DTHPH(IW)=DC2*DRAD DTHFR(IW)=DC3*DRAD 1110 CONTINUE IF(IPRINT.EQ.0) RETURN WRITE(IUN16,17002) NW WRITE(IUN16,17003) RETURN C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Format statements: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 17001 FORMAT(' Routine ETPHAS, version 1996.08.04.'// 1' Tidal component development from tidal potential development.'// 2 1X,A13,' tidal potential development is used.'/) 17002 FORMAT(//' Routine ETPHAS, version 1996.08.04.'/ 1'New phases and frequencies computes for',I6,' waves.') 17003 FORMAT(///' ***** Routine ETPHAS finished execution.'/) END C SUBROUTINE ETPOLC(IUN16,IUN30,IUN31,IPRINT,DJULD,DCLAT,DSLAT, 1 DCLON,DSLON,DPOLX,DPOLY,DUT1,DTAI,DLOD,DGPOL,DGPOLP,DGLOD,NERR) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C ! C Routine ETPOLC, version 1996.05.25 Fortran 90. ! C ! C The routine ETPOLC returns pole coordinates and correction DUT1 ! C read from either formatted file on IUN30 or unformatted direct ! C access file on IUN31. In case that direct access file IUN31 does ! C not exist, it will be established by routine ETPOLC with file ! C /home/hwz/eterna34/commdat/etpolut1.uft. ! C ! C All variables with D as first character are DOUBLE PRECISION. ! C ! C Input parameter description: ! C ---------------------------- ! C ! C IUN16: Formatted line printer unit. ! C IUN30: Formatted file containing pole coordinates, DUT1 ! C and DTAI (e.g. file etpolut1.dat). ! C IUN31: Unformatted direct access file containing pole ! C coordinates, DUT1 and DTAI. This file will be ! C opened as file etpolut1.uft during the execution of ! C routine ETPOLC with STATUS=OLD if it exists and ! C with STATUS=NEW, if it does not exist. If the ! C file does not yet exist, etpolut1.uft will be ! C established during the execution of routine ! C ETPOLC. ! C IPRINT: Printout parameter. ! C for IPRINT = 0, nothing will be printed. ! C for IPRINT = 1, a short list will be printed. ! C for IPRINT = 2, a long list will be printed ! C DJULD: Julian date of the epoch, for which pole ! C coordinates, DUT1 and DTAI will be returned. ! C DCLAT: COS of latitude. ! C DSLAT: SIN of latitude. ! C DCLON: COS of longitude. ! C DSLON: SIN of longitude. ! C ! C Output parameter description: ! C ----------------------------- ! C ! C DPOLX: X-pole coordinate in arc sec. ! C DPOLY: Y-pole coordinate in arc sec. ! C DUT1: Difference UT1 minus UTC in sec. ! C DTAI: Difference TAI minus UT1 in sec. ! C DLOD: Length of day - 86400 sec in sec. ! C DGPOL: Pole tide in nm/s**2 for a rigid earth. ! C DGPOLP: Time derivative of pole tide for a rigid earth in ! C nm/s**2 per day. ! C DGLOD: Gravity variation due to variation of the earth's ! C rotation in nm/s**2. ! C NERR: Error code, counts the number of errors which ! C happened during the actual call of routine ETPOLC. ! C For NERR > 0, the output parameters DPOLX, DPOLY, ! C DUT1, DTAI, DLOD, DGPOL, DGPOLP do not contain ! C valid information (all set to zero). ! C For NERR=0, the output parameters DPOLX, DPOLY, ! C DUT1 and DTAI contain valid information. ! C ! C Execution time: ! C --------------- ! C ! C 3.02 microsec per call on a 100 MHz Pentium using Lahey LF90 ! C compiler if the file ETPOLC.UFT exists already. ! C ! C Routine creation: 1993.08.31 by Hans-Georg Wenzel, ! C Black Forest Observatory, ! C Universitaet Karlsruhe, ! C Englerstr. 7, ! C D-76128 KARLSRUHE, ! C Germany. ! C Tel: 0049-721-6082307, ! C FAX: 0049-721-694552. ! C e-mail: wenzel@gik.bau-verm.uni-karlsruhe.de ! C Last modification: 1996.05.25 by Hans-Georg Wenzel. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPLICIT DOUBLE PRECISION (D) IMPLICIT INTEGER (I-N) CHARACTER CHEAD(8)*10,CENDH*10 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C COMMON /CONST/: to be initialized by BLOCK DATA. ! C DPI: 3.1415.... DPI2: 2.D0*DPI ! C DRAD: DPI/180.D0 DRO: 180.D0/DPI ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! COMMON /CONST/ DPI,DPI2,DRAD,DRO SAVE DATA DOM/7.292115D-5/,DA/6378137.D0/ DATA CENDH/'C*********'/,ISTART/1/,IMJDO/0/ NERR=0 IF(ISTART.EQ.0) GOTO 1000 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Test, whether there exist already unformatted file ETPOLUT1.UFT: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C HP-UNIX: OPEN(UNIT=IUN31,FILE='../commdat/etpolut1.uft', C HP-UNIX: 1 FORM='UNFORMATTED',STATUS='OLD',ACCESS='DIRECT',RECL=80,ERR=11) C MS-DOS: OPEN(UNIT=IUN31,FILE='/home/hwz/eterna34/commdat/etpolut2.uft', 1 FORM='UNFORMATTED',STATUS='OLD',ACCESS='DIRECT',RECL=32,ERR=11) WRITE(*,'(A$)')' FILE etpolut2.uft is existing ' READ(IUN31,REC=1) IFIRST,ILAST ISTART=0 GOTO 1000 C HP-UNIX: 11 OPEN(UNIT=IUN31,FILE='../commdat/etpolut1.uft', C HP-UNIX: 1 FORM='UNFORMATTED',STATUS='NEW',ACCESS='DIRECT',RECL=80) C MS-DOS: 11 OPEN(UNIT=IUN31,FILE='/home/hwz/eterna34/commdat/etpolut2.uft', 1 FORM='UNFORMATTED',STATUS='NEW',ACCESS='DIRECT',RECL=32) c REWIND IUN31 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Read file header of tidal potential file on unit IUN30: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(IPRINT.EQ.0) GOTO 10 WRITE(IUN16,17001) 10 CONTINUE READ(IUN30,17002) (CHEAD(I),I=1,8) WRITE(IUN16,17003) (CHEAD(I),I=1,8) 100 READ(IUN30,17002) (CHEAD(I),I=1,8) IF(IPRINT.GT.1) WRITE(IUN16,17003) (CHEAD(I),I=1,8) IF(CHEAD(1).NE.CENDH) GOTO 100 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Read data: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IREC=2 ILAST=0 200 READ(IUN30,17004) IDAT,ITIM,DMODJI,DPOLX,DPOLY,DUT1,DTAI IF(IDAT.EQ.99999999) GOTO 300 IF(IREC.EQ.2) IFIRST=DMODJI WRITE(IUN31,REC=IREC) DPOLX,DPOLY,DUT1,DTAI IF(IPRINT.GT.1) WRITE(IUN16,17005) IDAT,ITIM,IREC,DMODJI,DPOLX, 1 DPOLY,DUT1,DTAI ILAST=IREC IREC=IREC+1 GOTO 200 300 CONTINUE WRITE(IUN31,REC=1) IFIRST,ILAST write(*,*)ifirst,ilast ISTART=0 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Read pole coordinates, DUT1 and DTAI from direct access unit ! C IUN31: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1000 DMODJD=DJULD-2400000.5D0 IMJD=DMODJD C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C DT is time difference referring to central sample point in days: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DT=DMODJD-DBLE(IMJD) DT2=DT*DT IREC=IMJD-IFIRST+2 IF(IREC.LT.2) THEN DPOLX=0.D0 DPOLY=0.D0 DUT1 =0.D0 DTAI =0.D0 DLOD =0.D0 DGPOL=0.D0 DGPOLP=0.D0 NERR=1 RETURN ENDIF IF(IREC.GT.ILAST-1) THEN C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Use pole coordinates and DUT1 from last tabulated day: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! READ(IUN31,REC=ILAST) DPOLX,DPOLY,DUT1,DTAI DLOD =0.D0 DGPOL=DOM**2*DA*2.D0*DCLAT*DSLAT*(DPOLX*DCLON-DPOLY*DSLON)* 1 DRAD/3600.D0*1.D9 DGPOLP=0.D0 NERR=1 RETURN ENDIF IF(IMJD.EQ.IMJDO) GOTO 1100 READ(IUN31,REC=IREC-1) DPOLX1,DPOLY1,DUT12,DTAI1 READ(IUN31,REC=IREC) DPOLX2,DPOLY2,DUT12,DTAI2 READ(IUN31,REC=IREC+1) DPOLX3,DPOLY3,DUT13,DTAI3 IMJDO=IMJD C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Quadratic interpolation for pole coordinates and DTAI: ! C Linear interpolation for DUT1: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1100 DPOLXA0=DPOLX2 DPOLXA1=(DPOLX3-DPOLX1)*0.5D0 DPOLXA2=(DPOLX1-2.D0*DPOLX2+DPOLX3)*0.5D0 C DPOLYA0=DPOLY2 DPOLYA1=(DPOLY3-DPOLY1)*0.5D0 DPOLYA2=(DPOLY1-2.D0*DPOLY2+DPOLY3)*0.5D0 C DTAIA0=DTAI2 DTAIA1=(DTAI3-DTAI1)*0.5D0 DTAIA2=(DTAI1-2.D0*DTAI2+DTAI3)*0.5D0 C DUT10=DUT12 DDUT1=DUT13-DUT12 IF(DDUT1.GT. 0.9D0) DDUT1=DDUT1-1.D0 IF(DDUT1.LT.-0.9D0) DDUT1=DDUT1+1.D0 DLOD = DTAIA1+2.D0*DTAIA2*DT DGLOD=2.D0*DLOD*DOM**2*DA*DCLAT*DCLAT*1.D9/86400.D0 C DPOLX=DPOLXA0+DT*DPOLXA1+DT2*DPOLXA2 DPOLY=DPOLYA0+DT*DPOLYA1+DT2*DPOLYA2 DUT1 =DUT10 +DT*DDUT1 DTAI =DTAIA0 +DT*DTAIA1 +DT2*DTAIA2 C DGPOL=DOM**2*DA*2.D0*DCLAT*DSLAT*(DPOLX*DCLON-DPOLY*DSLON)* 1 DRAD/3600.D0*1.D9 DPOLXP=DPOLXA1+2.D0*DPOLXA2*DT DPOLYP=DPOLYA1+2.D0*DPOLYA2*DT DGPOLP=DOM**2*DA*2.D0*DCLAT*DSLAT*(DPOLXP*DCLON-DPOLYP*DSLON)* 1 DRAD/3600.D0*1.D9 RETURN C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Format statements: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 17001 FORMAT(' Routine ETPOLC, version 1996.05.25.'// 1' Pole coordinates, DUT1, DTAI and pole tides from IERS data.'//) 17002 FORMAT(8A10) 17003 FORMAT(1X,8A10) 17004 FORMAT(I8,1X,I6,F10.3,5F10.5) 17005 FORMAT(I9,1X,2I6,F10.3,5F10.5) END C SUBROUTINE ETPOTS(IUN14,IUN16,IUN24,IPRINT,IMODEL,DLAT,DLON,DH, 1 DGRAV,DAZ,IC,DJULD,DAMIN) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C ! C Routine ETPOTS, version 1997.09.20 Fortran 90. ! C ! C The routine ETPOTS computes amplitudes, phases, frequencies and ! C body tide amplitude factors for a number of different Earth tide ! C components using different tidal potential catalogues which use ! C the Hartmann and Wenzel (1995) normalization. ! C ! C Attention: This routine has finally not been tested for vertical ! C and horizontal displacements and for shear tidal ! C strain !!!! ! C ! C All variables with D as first character are DOUBLE PRECISION. ! C ! C Input parameter description: ! C ---------------------------- ! C ! C IUN14: Formatted unit, on which the tidal potential ! C development has to be stored before the execution ! C of routine ETPOTS (e.g. file hw95s.dat). ! C IUN16: Formatted line printer unit. ! C IUN24: Unformatted copy of IUN14. This unit will be opened ! C e.g. as file hw95s.uft during the execution of ! C routine ETPOTS with STATUS=OLD if it exists and ! C with STATUS=NEW, if it does not exist. If the file ! C does not yet exist, it will be established during ! C the execution of routine ETPOTS. ! C IPRINT: Printout parameter. ! C for IPRINT = 0, nothing will be printed. ! C for IPRINT = 1, a short list will be printed. ! C for IPRINT = 2, a long list will be printed ! C (including the tidal potential development). ! C IMODEL: Parameter for selecting the tidal potential ! C development. ! C IMODEL = 1: Doodson (1921) tidal potential develop- ! C ment with 378 waves. ! C IMODEL = 2: Cartwright-Taylor-Edden (1973) tidal ! C potential development with 505 waves. ! C IMODEL = 3: Buellesfeld (1985) tidal potential ! C development with 656 waves. ! C IMODEL = 4: Tamura (1987) tidal potential develop- ! C ment with 1200 waves. ! C IMODEL = 5: Xi (1989) tidal potential catalogue ! C 2933 waves. ! C IMODEL = 6: Roosbeek (1995) tidal potential ! C catalogue with ?? waves. ! C IMODEL = 7: Hartmann and Wenzel (1995) tidal ! C potential catalogue with 12935 waves. ! C DLAT: Ellipsoidal latitude referring to Geodetic ! C Reference System 1980 in degree. ! C DLON: Ellipsoidal longitude referring to Geodetic ! C Reference System 1980 in degree, positive east of ! C Greenwhich. ! C DH: Ellipsoidal height referring to Geodetic Reference ! C System 1980 in meter. ! C DGRAV: Gravity in m/s**2. If the gravity is input below ! C 1 m/s**2, the gravity will be replaced by the ! C computed normal gravity for reference system GRS80. ! C DAZ: Azimuth in degree from north direction (only valid ! C for tidal tilt, horizontal displacement, and ! C horizontal strain). ! C IC: Earth tide component to be computed. ! C IC=-1: tidal potential in m**2/s**2. ! C IC= 0: vertical tidal acceleration (gravity tide), ! C in nm/s**2 (positive downwards). ! C IC= 1: horizontal tidal acceleration (tidal tilt) ! C in azimuth DAZ in mas = arc sec/1000. ! C IC= 2: vertical tidal displacement, geodetic ! C coefficients in mm (positive upwards). ! C IC= 3: horizontal tidal displacement in azimuth ! C DAZ in mm. ! C IC= 4: vertical tidal strain in 10**-9 = nstr. ! C IC= 5: horizontal tidal strain in azimuth DAZ ! C in 10**-9 = nstr. ! C IC= 6: areal tidal strain in 10**-9 = nstr. ! C IC= 7: shear tidal strain in 10**-9 = nstr. ! C IC= 8: volume tidal strain in 10**-9 = nstr. ! C IC= 9: ocean tides, geodetic coefficients in ! C millimeter. ! C DJULD: Julian date of the initial epoch of tidal force ! C development. ! C DAMIN: Truncation parameter for the amplitude of tidal ! C waves to be used in m**2/s**2. Only tidal waves ! C with amplitudes greater or equal DAMIN will be ! C used. ! C ! C Rms error of gravity tides compited from HW95 tidal ! C potential catalogue versus amaplitude threshold, ! C as computed from comparison with benchmark gravity ! C tide series BFDE403A ! C ! C DAMIN no. of rms error min. error max.error ! C [m**2/s**2] waves [nm/s**2] [nm/s**2] [nm/s**2] ! C ! C 1.00*10**-1 11 88.403330 -321.492678 297.866988 ! C 3.16*10**-2 28 27.319455 -108.174675 109.525103 ! C 1.00*10**-2 45 14.449139 -62.286861 67.322802 ! C 3.16*10**-3 85 6.020159 -32.560229 28.931931 ! C 1.00*10**-3 158 2.249690 -14.587415 11.931120 ! C 3.16*10**-4 268 0.978419 -6.780051 5.934767 ! C 1.00*10**-4 441 0.436992 -3.049676 2.943019 ! C 3.16*10**-5 768 0.173071 -1.331572 1.242490 ! C 1.00*10**-5 1 273 0.068262 -0.520909 0.484510 ! C 3.16*10**-6 2 052 0.029229 -0.217114 0.229504 ! C 1.00*10**-6 3 359 0.011528 -0.099736 0.085920 ! C 3.16*10**-7 5 363 0.004706 -0.038247 0.035942 ! C 1.00*10**-7 8 074 0.001999 -0.019407 0.017684 ! C 3.16*10**-8 10 670 0.001391 -0.012350 0.012287 ! C 1.00*10**-8 12 234 0.001321 -0.010875 0.011307 ! C ! C Output parameter description: ! C ----------------------------- ! C ! C There are no output parameters. The computed arrays are trans- ! C ferred to the calling program unit by COMMON /TIDWAVE/. ! C ! C COMMON /TIDWAVE/: contains tidal waves ! C ! C NW: Number of defined tidal waves. ! C IWNR: INTEGER array (1:12935) of wave numbers. ! C IAARG: INTEGER array (1:12935,1:12) of astronomical ! C argument numbers. ! C DX0: DOUBLE PRECISION array (1:12935) of cos-coeffi- ! C cients of the tidal component in units of the tidal ! C component. ! C DX1: DOUBLE PRECISION array (1:12935) of time deriva- ! C tives of cos-coefficients of the tidal component. ! C DY0: DOUBLE PRECISION array (1:12935) of sin-coeffi- ! C cients of the tidal component in units of the tidal ! C component. ! C DY1: DOUBLE PRECISION array (1:12935) of time deriva- ! C tives of sin-coefficients of the tidal component. ! C ! C component unit of unit of ! C IC DX0,DY0 DX1,DY1 ! C -1 m**2/s**2 m**2/s**2 per Julian century ! C 0 nm/s**2 nm/s**2 per Julina century ! C 1 mas mas per Julian century ! C 2 mm mm per Julian century ! C 3 mm mm per Julian century ! C 4 nstr nstr per Julian cenrury ! C 5 nstr nstr per Julian century ! C 6 nstr nstr per Julian century ! C 7 nstr nstr per Julian century ! C 8 nstr nstr per Julian century ! C 9 mm mm per Julian century ! C ! C DTHPH: DOUBLE PRECISION array (1:12935) of tidal phases ! C in radians at initial epoch. ! C DTHFR: DOUBLE PRECISION array (1:12935) of tidal ! C frequencies in radian per hour. ! C DBODY: DOUBLE PRECISION array (1:12935) of body tide ! C amplitude factors for tidal gravity and tidal tilt. ! C In order to compute the body tide, the coefficients ! C DX0, DX1, DY0 and DY1 have to be multiplied by ! C DBODY. ! C ! C Used routines: ! C -------------- ! C ! C ETASTN: computes astronomical elements. ! C ETGCON: computes geodetic coefficients. ! C ETJULN: computes Julian date. ! C ETLOVE: computes latitude dependent elastic parameters (called ! C ETGCOF). ! C ETDDTA: computes the difference TDT minus UTC (called by ETASTN).! C ETPOLC: computes the difference DUT1 = UT1 - UTC. ! C ! C Numerical accuracy: ! C ------------------- ! C ! C The routine has been tested under operation systems UNIX and ! C MS-DOS with 15 digits in DOUBLE PRECISION. ! C ! C Routine creation: 1988.04.27 by Hans-Georg Wenzel, ! C Black Forest Observatory, ! C Universitaet Karlsruhe, ! C Englerstr. 7, ! C D-76128 KARLSRUHE 1, ! C Germany. ! C Tel: 0049-721-6082307, ! C FAX: 0049-721-694552. ! C e-mail: wenzel@gik.bau-verm.uni-karlsruhe.de ! C Last modification: 1997.09.20 by Hans-Georg Wenzel. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPLICIT DOUBLE PRECISION (D) IMPLICIT INTEGER (I-N) LOGICAL LEX24 CHARACTER CHEAD(8)*10,CENDH*10,CUNIT(11)*8 CHARACTER CMODEL(7)*20,CFFILE(7)*64,CUFILE(7)*64 CHARACTER CBOD*2,CWAVE*4 INTEGER NS(11) DOUBLE PRECISION DAS(11),DASP(11),DGK(25),DPK(25) COMMON /TIDPHAS/ DPK C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C The following DIMENSION statement is concerning the number of ! C waves of the tidal potential development, which is 12935. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! COMMON /TIDWAVE/ NW,IWNR(12935),IAARG(12935,12),DX0(12935), 1 DX1(12935),DY0(12935),DY1(12935),DTHPH(12935),DTHFR(12935), 2 DBODY(12935) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C The following DIMENSION statement is concerning the elastic ! C Earth model for the different degree and order constituents. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DOUBLE PRECISION DELTA(25) COMMON /UNITS/ CUNIT,IC2 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C COMMON /CONST/: To be initialized by BLOCK DATA: ! C DPI: 3.1415.... DPI2: 2.D0*DPI ! C DRAD: DPI/180.D0 DRO: 180.D0/DPI ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! COMMON /CONST/ DPI,DPI2,DRAD,DRO C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C COMMON /LOVE/ contains gravimeter factors, LOVE-numbers, SHIDA- ! C numbers and tilt factors for degree 2...4 at latitude DLAT: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DIMENSION DGLAT(12),DHLAT(12),DKLAT(12),DLLAT(12),DTLAT(12) COMMON /LOVE/ DOM0,DOMR,DGLAT,DGR,DHLAT,DHR,DKLAT,DKR,DLLAT,DLR, 1 DTLAT,DTR SAVE DATA MAXNW/12935/ DATA CENDH/'C*********'/ DATA IUN30/30/,IUN31/31/ DATA CMODEL/'Doodson 1921 ', 1 'CTED 1973 ','Buellesfeld 1985 ', 2 'Tamura 1987 ','Xi 1989 ', 3 'Roosbeek 1995 ','Hartmann+Wenzel 1995'/ C HP-UNIX: C HP-UNIX: DATA CFFILE/ '../commdat\doodsehw.dat', C HP-UNIX: 2 '../commdat\cted73hw.dat', C HP-UNIX: 3 '../commdat\buellehw.dat', C HP-UNIX: 4 '../commdat\tamurahw.dat', C HP-UNIX: 5 '../commdat\xi1989hw.dat', C HP-UNIX: 6 '../commdat\ratgp95.dat', C HP-UNIX: 7 '../commdat\hw95s.dat'/ C HP-UNIX: DATA CUFILE/ '../commdat\doodsehw.uft', C HP-UNIX: 2 '../commdat\cted73hw.uft', C HP-UNIX: 3 '../commdat\buellehw.uft', C HP-UNIX: 4 '../commdat\tamurahw.uft', C HP-UNIX: 5 '../commdat\xi1989hw.uft', C HP-UNIX: 6 '../commdat\ratgp95.uft', C HP-UNIX: 7 '../commdat\hw95s.uft'/ C MS-DOS: DATA CFFILE/ '/home/hwz/eterna34/commdat/doodsehw.dat', 2 '/home/hwz/eterna34/commdat/cted73hw.dat', 3 '/home/hwz/eterna34/commdat/buellehw.dat', 4 '/home/hwz/eterna34/commdat/tamurahw.dat', 5 '/home/hwz/eterna34/commdat/xi1989hw.dat', 6 '/home/hwz/eterna34/commdat/ratgp95.dat', 7 '/home/hwz/eterna34/commdat/hw95s.dat'/ DATA CUFILE/ '/home/hwz/eterna34/commdat/doodseh2.uft', 2 '/home/hwz/eterna34/commdat/cted73h2.uft', 3 '/home/hwz/eterna34/commdat/buelleh2.uft', 4 '/home/hwz/eterna34/commdat/tamurah2.uft', 5 '/home/hwz/eterna34/commdat/xi1989h2.uft', 6 '/home/hwz/eterna34/commdat/ratgp952.uft', 7 '/home/hwz/eterna34/commdat/hw95s2.uft'/ IF(IPRINT.GT.0) WRITE(IUN16,17001) CMODEL(IMODEL) OPEN(UNIT=IUN14,FILE=CFFILE(IMODEL),FORM='FORMATTED', 1 STATUS='OLD') REWIND(IUN14) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Test, whether there exist already the unformatted tidal ! C potential catalogue file: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! OPEN(UNIT=IUN24,FILE=CUFILE(IMODEL),FORM='UNFORMATTED', 1 STATUS='OLD',ERR=11) LEX24=.TRUE. REWIND IUN24 GOTO 12 11 OPEN(UNIT=IUN24,FILE=CUFILE(IMODEL),FORM='UNFORMATTED', 1 STATUS='NEW') LEX24=.FALSE. REWIND IUN14 12 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute geodetic coefficients and body tide amplitude factors ! C for the WAHR-DEHANT-ZSCHAU model. The NDFW resonance is ! C approximated by ! C ! C G0 - GR*(DOM - DOM0)/(DOMR - DOM), ! C ! C similar equations hold for the other components. ! C ! C Gravimetric amplitude factors, LOVE numbers h and k for zero to ! C third degree tidal potential have been taken from DEHANT 1987, ! C table 7, 8 and 9 for elliptical, uniformly rotating, oceanless ! C Earth with liquid outer core and inelastic mantle (PREM Earth ! C model with inelastic mantle from ZSCHAU) and for the fourth ! C degree from DEHANT et al. 1989, table 6). The resonance factors ! C GR have been computed to fit the difference between body tide ! C amplitude factors at waves O1 and PSI1 from DEHANT 1987, PREM ! C model with elastic mantle (table 1...3). The NDFW resonance ! C frequency is 15.073729 degree per hour = 1.004915267 CPD UT, ! C taken from WAHR 1981 (because it is not given in any of DEHANT's ! C papers). ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CALL ETGCON(IUN16,IPRINT,DLAT,DLON,DH,DGRAV,DAZ,IC,DGK,DPK) IC2=IC+2 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Define default body tide amplitude factors for components ! C IC=2...9. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DO 50 I=1,25 50 DELTA(I)=1.D0 DELTAR=0.D0 GOTO (100,200,300),IC2 GOTO 1000 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C IC=-1, compute body tide amplitude factors for tidal potential: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 100 CONTINUE DO 110 I=1,12 110 DELTA(I)=DKLAT(I) DELTAR=DKR GOTO 1000 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C IC=0, compute body tide amplitude factors for vertical component ! C (gravity tides): ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 200 CONTINUE DO 210 I=1,12 210 DELTA(I)=DGLAT(I) DELTAR=DGR GOTO 1000 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C IC=1: compute body tide amplitude factors for horizontal ! C component (tidal tilt): ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 300 CONTINUE DO 310 I=1,12 310 DELTA(I)=DTLAT(I) DELTAR=DKR-DHR 1000 CONTINUE DT2000=(DJULD-2451544.D0)/36525.0D0 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Interpolate DUT1: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CALL ETPOLC(IUN16,IUN30,IUN31,IPRINT,DJULD,DCLAT,DSLAT, 1 DCLON,DSLON,DPOLX,DPOLY,DUT1,DTAI,DLOD,DGPOL,DGPOLP,DGLOD,NERR) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute astronomical elements for initial epoch: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CALL ETASTN(IUN16,IPRINT,IMODEL,DLON,DJULD,DUT1,DAS,DASP,DDT0) IC2=IC+2 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Read file header of tidal potential file on unit IUN14: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(LEX24) THEN READ(IUN24) (CHEAD(I),I=1,8) ELSE READ(IUN14,17028) (CHEAD(I),I=1,8) WRITE(IUN24) (CHEAD(I),I=1,8) ENDIF WRITE(IUN16,17029) (CHEAD(I),I=1,8) 1100 CONTINUE IF(LEX24) THEN READ(IUN24) (CHEAD(I),I=1,8) ELSE READ(IUN14,17028) (CHEAD(I),I=1,8) WRITE(IUN24) (CHEAD(I),I=1,8) ENDIF IF(IPRINT.EQ.2) WRITE(IUN16,17029) (CHEAD(I),I=1,8) IF(CHEAD(1).NE.CENDH) GOTO 1100 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute tidal development for the specific component from tidal ! C potential development: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IW=1 NWFILE=0 NAMPL=0 NTRUNC=0 1110 CONTINUE 1120 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Read tidal potential catalogue either from formatted or from ! C unformatted file. The format of the files is described in ! C Hartmann and Wenzel (1995a). ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(LEX24) THEN READ(IUN24) NRI,CBOD,LI,(NS(J),J=1,11),DFR,DC0I,DS0I,DC1I, 1 DS1I,CWAVE ELSE READ(IUN14,17006,END=2000) NRI,CBOD,LI,(NS(J),J=1,11),DFR, 1 DC0I,DS0I,DC1I,DS1I,CWAVE WRITE(IUN24) NRI,CBOD,LI,(NS(J),J=1,11),DFR,DC0I,DS0I,DC1I, 1 DS1I,CWAVE ENDIF IF(NRI.GT.MAXNW) GOTO 2000 NWFILE=NWFILE+1 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Truncation of the tidal potential catalogue: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DAM=DSQRT(DC0I**2+DS0I**2)*1.D-10 IF(DAM.LT.DAMIN) THEN NTRUNC=NTRUNC+1 GOTO 1110 ENDIF IF(IW.EQ.1) GOTO 1130 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Check if the astronomical arguments are identical to those of ! C the last stored wave (for Hartmann and Wenzel 1995 potential): ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IDIFF=(LI-IAARG(IW-1,12))**2 DO 1125 J=1,11 1125 IDIFF=IDIFF+(NS(J)-IAARG(IW-1,J))**2 IF(IDIFF.GT.0) GOTO 1130 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Astronomical arguments are identical to those of last stored ! C wave. We will add up the coefficients for these two waves: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF(IW-1.GT.1) IWNR(IW-1)=NRI JCOF=(LI+1)*LI/2-2+NS(1) DX0(IW-1)=DX0(IW-1)+DC0I*DGK(JCOF)*1.D-10 DY0(IW-1)=DY0(IW-1)+DS0I*DGK(JCOF)*1.D-10 DX1(IW-1)=DX1(IW-1)+DC1I*DGK(JCOF)*1.D-10 DY1(IW-1)=DY1(IW-1)+DS1I*DGK(JCOF)*1.D-10 GOTO 1110 1130 NAMPL=NAMPL+1 DC2=0.D0 DC3=0.D0 IAARG(IW,12)=LI DO 1140 J=1,11 IAARG(IW,J)=NS(J) DC2=DC2+DBLE(NS(J))*DAS(J) 1140 DC3=DC3+DBLE(NS(J))*DASP(J) JCOF=(LI+1)*LI/2-2+NS(1) DC2=DC2+DPK(JCOF) IWNR(IW)=NRI DX0(IW)=DC0I*DGK(JCOF)*1.D-10 DY0(IW)=DS0I*DGK(JCOF)*1.D-10 DX1(IW)=DC1I*DGK(JCOF)*1.D-10 DY1(IW)=DS1I*DGK(JCOF)*1.D-10 DBODY(IW)=DELTA(JCOF) IF(JCOF.EQ.2) DBODY(IW)=DELTA(JCOF)+DELTAR*(DC3-DOM0)/(DOMR-DC3) 1160 DC2=DMOD(DC2,360.D0) IF(DC2.GE.0.D0) GOTO 1170 DC2=DC2+360.D0 GOTO 1160 1170 CONTINUE DTHPH(IW)=DC2*DRAD DTHFR(IW)=DC3*DRAD IF(IPRINT.EQ.2) THEN DXTI=DX0(IW)+DX1(IW)*DT2000 DYTI=DY0(IW)+DY1(IW)*DT2000 DTHAM=DSQRT(DXTI**2+DYTI**2) WRITE(IUN16,17011) IW,CBOD,LI,NS(1),DTHAM,DC2,DC3,CWAVE, 1 DBODY(IW) ENDIF IW=IW+1 IF(IW.GT.MAXNW) GOTO 5000 GOTO 1110 2000 CONTINUE NW=IW-1 CLOSE(IUN14) IF(IPRINT.EQ.0) RETURN WRITE(IUN16,17010) NWFILE,NTRUNC,NW WRITE(IUN16,17030) RETURN 5000 CONTINUE WRITE(IUN16,17050) NW,MAXNW STOP C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Format statements: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 17001 FORMAT(//6X,'Routine ETPOTS, version 1997.09.20.'/ 1 6x,'Tidal waves from tidal potential catalogue.'/ 2 6X,A20,' tidal potential catalogue is used.'/) 17006 FORMAT(I6,1X,A2,I2,11I3,F12.8,2F12.0,2F10.0,1X,A4) 17008 FORMAT(1X,I4,10I2,4F7.5,F8.4,F9.4,F12.8,1X,A4/F7.5,F8.6,F9.6) 17010 FORMAT(//6x,' Number of waves read from file is :',I6/ 1 6x,' Number of waves below limit is :',I6/ 1 6x,' Number of waves to be used is :',I6/) 17011 FORMAT(I5,1X,A2,2I3,3F10.5,2X,A6,2X,F10.6) 17028 FORMAT(8A10) 17029 FORMAT(6X,8A10) 17030 FORMAT(///6x,'***** Routine ETPOTS finished execution.'/) 17050 FORMAT(/ 1 6x,'***** Error in routine ETPOTS.'/ 2 6x,'***** The current number of waves:',I5,' exceeds the ', 3 'maximum number of waves:',I5/ 4 6x,'***** Routine ETPOTS stops the execution.'/) END C SUBROUTINE GEOEXT(IUN16,IRESET,ISCREEN,DEXTIM,DEXTOT) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C ! C Routine GEOEXT, version 1997.08.22 Fortran 90. ! C ! C The routine GEOEXT computes the actual job time and writes ! C the actual execution time on printer output unit IUN6. ! C For the first call of routine GEOEXT, the actual jobtime will ! C be computed (in secs since midnight) and stored. For the next ! C call(s) of routine GEOEXT, the actual jobtime will be computed ! C and the execution time (actual jobtime minus jobtime of the ! C first call of routine GEOEXT) will be printed. ! C ! C Input parameter description: ! C ---------------------------- ! C ! C IUN16: formatted printer unit. ! C IRESET: DEXTIM will be resetted, if IRESET=1. ! C ISCREEN: Execution time will also be written on the screen ! C of the PC. ! C ! C Output parameter description: ! C ----------------------------- ! C ! C DEXTIM: actual jobtime in seconds (time elapsed from the ! C last call of routine GEOEXT with IRESET=1 to the ! C actual call of routine GEOEXT), double precision. ! C DEXTOT: total jobtime in seconds (time elapsed from the ! C first call of routine GEOEXT), double precision. ! C ! C Used routines: ! C -------------- ! C ! C SYSTEM-CLOCK ! C ! C Execution time: ! C --------------- ! C ! C 0.17 msec per call of GEOEXT with ISCREEN=0 on a PENTIUM 100 MHZ ! C PC. ! C ! C Program creation: 1979.08.30 by Hans-Georg Wenzel, ! C Black Forest Observatory, ! C Universitaet Karlsruhe, ! C Englerstr. 7, ! C D-76128 KARLSRUHE, ! C Germany. ! C Tel.: 0721-6082301. ! C FAX: 0721-694552. ! C e-mail: wenzel@gik.bau-verm.uni-karlsruhe.de ! C Last Modification: 1997.08.22 by Hans-Georg Wenzel. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPLICIT DOUBLE PRECISION (D) C MSFOR: INTEGER*2 IH,IM,IS,IS100 DATA IFIRST/1/ SAVE DTIME1 IF(IRESET.NE.1) GOTO 6003 C MSFOR: CALL GETTIM(IH,IM,IS,IS100) C MSFOR: DTIME1=DBLE(IS+IM*60+IH*3600)+0.01*FLOAT(IS100) C LAHEY 90: CALL SYSTEM_CLOCK(IC,ICR) DTIME1=DBLE(IC)/DBLE(ICR) C UNIX: DTIME1=DBLE(SECNDS(RDUMMY)) WRITE(IUN16,17001) IF(ISCREEN.EQ.1) WRITE(*,17001) DEXTIM=0.D0 DEXTOT=0.D0 IF(IFIRST.EQ.1) THEN DTIME0=DTIME1 IFIRST=0 ENDIF IRESET=0 RETURN 6003 CONTINUE C MSFOR: CALL GETTIM(IH,IM,IS,IS100) C MSFOR: DTIME2=DBLE(IS+IM*60+IH*3600)+0.01*FLOAT(IS100) C LAHEY: CALL SYSTEM_CLOCK(IC,ICR) DTIME2=DBLE(IC)/DBLE(ICR) C UNIX: DTIME2=DBLE(SECNDS(RDUMMY)) DEXTIM=DTIME2-DTIME1 DEXTOT=DTIME2-DTIME0 WRITE(IUN16,17002) DEXTIM IF(ISCREEN.EQ.1) WRITE(*,17002) DEXTIM C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Format statements: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 17001 FORMAT(6x,'First call of routine GEOEXT, version 1997.08.22.') 17002 FORMAT(/6x,'Routine GEOEXT. Execution time=',F10.3,' sec'/) RETURN END C SUBROUTINE JACOBI(IUN16,A,N,NP,D,V,NROT,DCOND) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C ! C Routine JACOBI, version 1996.05.25 Fortran 90. ! C ! C The routine computes eigenvalues, eigenvectors and spectral ! C condition number of a real symmetric matrix. JACOBI is a modi- ! C fied version of routine JACOBI taken from ! C Press, W.H., S.A: Teukolsky, W.T. Vetterling and B.P. Flannery ! C (1992): Numerical recipes in Fortran: The art of scientific ! C computing, 2nd edition, Cambridge University Press, 1992. ! C ! C ! C Input parameter description: ! C ---------------------------- ! C ! C IUN16: Formatted printer unit. ! C A: DOUBLE PRECISION real symmetric input matrix, for ! C which the eigenvalues and eigenvectors will be com- ! C puted. The physical dimension of A is NP*NP, the ! C actual dimension of A is N*N. ! C Attention: matrix A will be destroyed during execu- ! C tion of routine JACOBI !!! ! C N: INTEGER actual dimension of matrix A. N is restric- ! C ted to be less or equal NP. ! C NP: INTEGER physical dimension of matrix A. NP is ! C restricted to be less or equal 175 (PARAMETER NMAX).! C ! C Output parameter description: ! C ----------------------------- ! C ! C D: DOUBLE PRECISION vector of eigenvalues of matrix A. ! C The physical dimension of D is NP, the actual ! C dimension of D is N. ! C V: DOUBLE PRECISION matrix of eigenvectors of matrix ! C A. The physical dimension of V is NP*NP, the actual ! C dimension of V is N*N. ! C NROT: INTEGER number of Jabobi rotations, performed by ! C JACOBI. ! C DCOND: DOUBLE PRECISION spectral condition number of ! C matrix A. ! C ! C Execution time: ! C --------------- ! C ! C For N=33, the execution time was 0.05 s on a 100 MHz Pentium. ! C ! C Program creation: 1996.01.22 by Hans-Georg Wenzel, ! C Black Forest Observatory, ! C Universitaet Karlsruhe, ! C Englerstr. 7, ! C D-76128 KARLSRUHE, ! C Germany. ! C Tel.: 0721-6082301. ! C FAX: 0721-694552. ! C e-mail: wenzel@gik.bau-verm.uni-karlsruhe.de ! C Last Modification: 1996.05.25 by Hans-Georg Wenzel. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPLICIT DOUBLE PRECISION (D) INTEGER N,NP,NROT,NMAX DOUBLE PRECISION A(NP,NP),D(NP),V(NP,NP),DCOND PARAMETER (NMAX=175) INTEGER I,IP,IQ,J DOUBLE PRECISION C,G,H,S,SM,T,TAU,THETA,TRESH,B(NMAX),Z(NMAX) DATA DEPS/1.D-20/ IF(N.GT.NMAX) THEN WRITE(IUN16,7001) STOP ENDIF DO 12 IP=1,N DO 11 IQ=1,N 11 V(IP,IQ)=0.D0 12 V(IP,IP)=1.D0 DO 13 IP=1,N B(IP)=A(IP,IP) D(IP)=B(IP) 13 Z(IP)=0.D0 NROT=0 DO 24 I=1,50 SM=0.D0 DO 15 IP=1,N-1 DO 15 IQ=IP+1,N 15 SM=SM+DABS(A(IP,IQ)) IF(SM.EQ.0.D0) GOTO 5000 IF(I.LT.4) THEN TRESH=0.2D0*SM/N**2 ELSE TRESH=0.D0 ENDIF DO 22 IP=1,N-1 DO 21 IQ=IP+1,N G=100.D0*DABS(A(IP,IQ)) C IF((I.GT.4).AND.(DABS(IP))+ C *G.EQ.DABS(D(IP))).AND.(DABS(D(IQ))+G.EQ.DABS(D(IQ)))) THEN IF((I.GT.4).AND.(G.LT.DEPS)) THEN A(IP,IQ)=0.D0 ELSE if(Dabs(a(ip,iq)).GT.TRESH)then H=D(IQ)-D(IP) C IF(DABS(H)+G.EQ.DABS(H)) THEN IF(G.LT.DEPS) THEN T=A(IP,IQ)/H ELSE THETA=0.5D0*H/A(IP,IQ) T=1.D0/(DABS(THETA)+DSQRT(1.D0+THETA**2)) IF(THETA.lt.0.D0) T=-T ENDIF C=1.D0/DSQRT(1.D0+T**2) S=T*C TAU=S/(1.D0+C) H=T*A(IP,IQ) Z(IP)=Z(IP)-H Z(IQ)=Z(IQ)+H D(IP)=D(IP)-H D(IQ)=D(IQ)+H A(IP,IQ)=0.D0 DO 16 J=1,IP-1 G=A(J,IP) H=A(J,IQ) A(J,IP)=G-S*(H+G*TAU) 16 A(J,IQ)=H+S*(G-H*TAU) DO 17 J=IP+1,IQ-1 G=A(IP,J) H=A(J,IQ) A(IP,J)=G-S*(H+G*TAU) 17 A(J,IQ)=H+S*(G-H*TAU) DO 18 J=IQ+1,N G=A(IP,J) H=A(IQ,J) A(IP,J)=G-S*(H+G*TAU) 18 A(IQ,J)=H+S*(G-H*TAU) DO 19 J=1,N G=V(J,IP) H=V(J,IQ) V(J,IP)=G-S*(H+G*TAU) 19 V(J,IQ)=H+S*(G-H*TAU) NROT=NROT+1 ENDIF 21 CONTINUE 22 CONTINUE DO 23 ip=1,n B(IP)=B(IP)+Z(IP) D(IP)=B(IP) 23 Z(IP)=0.D0 24 CONTINUE WRITE(*,*) ' ****too many iterations in routine JACOBI' WRITE(IUN16,*) ' ****too many iterations in routine JOCOBI' 5000 CONTINUE C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Compute condition number DCOND: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DMIN=1.D90 DMAX=-1.D90 DO 5210 I=1,N IF(D(I).LT.DMIN) DMIN=D(I) IF(D(I).GT.DMAX) DMAX=D(I) 5210 CONTINUE DCOND=DMAX/DMIN RETURN C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Format statements: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 7001 FORMAT(' *** Error in routine JACOBI.'/ 1' *** Size of matrix too big. '/ 2' *** You have to increase parameter NMAX.', 3' *** Rotine JACOBI stops the execution.') END C SUBROUTINE WPRINT(IUN17,IPROJ,CPROJ,CPSTR,DEXTIM) C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C ! C Routine WPRINT, version 1996.05.25 Fortran 90. ! C ! C === MS-DOS version for LAHEY-compiler =================== ! C ! C The routine WPRINT updates the log-file IUN17 of program ANALYZE ! C and prints on the screen, either under UNIX or MS-DOS. ! C ! C Input parameter description: ! C ---------------------------- ! C ! C IUN17: Formatted log-file unit. ! C CPSTR: Print string (CHARACTER*56) ! C DEXTIM: Actual execution time in seconds. ! C ! C Routine creation: 1996.03.01 by Hans-Georg Wenzel, ! C Black Forest Observatory, ! C Universitaet Karlsruhe, ! C Englerstr. 7, ! C D-76128 KARLSRUHE, ! C Germany. ! C Tel.: 0721-6082301. ! C FAX: 0721-694552. ! C e-mail: wenzel@gik.bau-verm.uni-karlsruhe.de ! C Last Modification: 1996.05.25 by Hans-Georg Wenzel. ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPLICIT DOUBLE PRECISION (D) CHARACTER CPSTR*48,CPROJ*8,CNUMB*3,CEXTIM*9,CSTROUT*74 DATA IOLD/0/ IF(IPROJ.NE.IOLD) THEN WRITE(*,7003) WRITE(IUN17,7003) IOLD=IPROJ ENDIF WRITE(CNUMB,'(I3)') IPROJ WRITE(CEXTIM,'(F9.2)') DEXTIM CSTROUT=CNUMB//' '//CPROJ//': '//CPSTR//CEXTIM//' s' WRITE(IUN17,7001) CSTROUT WRITE(*,7002) CSTROUT RETURN C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C Format statements: ! C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 7001 FORMAT(A74) 7002 FORMAT(1X,A74) 7003 FORMAT(1X) END C
Become a Patron
Sponsor on GitHub
Donate via PayPal
Source on GitHub
Mailing list
Installed libraries
Wiki
Report an issue
How it works
Contact the author
CE on Mastodon
About the author
Statistics
Changelog
Version tree