SUBROUTINE START (ILU, CALCON_NAME, Iout) IMPLICIT None ! ! START initializes CALC. It reads the run title, the database experiment ! file to be processed, and the control namelist which contains non-default ! model module and utility routine flow control and debug output flags. It ! obtains the date and time of the CALC run from subroutine FDATE. It writes ! the CALC run title, the database experiment file to be processed, the run ! date and time, the load module message, and the values of all flow control ! and debug output flags in the program. The database is initialized for ! update, and the CALC run title, run date, run time, and the load module ! message are placed in the database through the call to PHIST. All flow ! control and debug output flags are loaded into the global common area CON ! for distribution to the routines called by DRIVR. START is called only ! once per database. START is the routine which stops CALC when the end of ! the control data set is reached. ! ! Calling sequence - CALL START(ILU, CALCON_NAME, iout) ! ! Input variables: ! 1) ILU - The output message logical unit. ! 2) CALCON_NAME - Full name with path for CALC control file. ! ! Common blocks used - ! INCLUDE 'ccon.i' ! Variables 'to': ! 1. KMODC - The model module flow control flags. ! 2. KMODD - The model module debug output flags. ! 3. KUTLC - The utility routine flow contol flags. ! 4. KUTLD - The utility routine debug output flags. ! 5. ILUOUT - A flag controlling output. ! INCLUDE 'cmxst.i' ! Variables 'to': ! 1. NUMSIT - The total number of sites in the data base. ! INCLUDE 'cmxsr.i' ! Variables 'to': ! 1. NUMSTR - The total number of stars (radio sources) in the ! data base. ! INCLUDE 'cmxut.i' ! Variables 'to': ! 1. Xintv(2) - First and last Julian Date of data in the ! current data base. ! 2. Intrvl(5,2) - First and last time tag of data in the current ! data base. (First index: year, month, day, ! hour, minute. Second index: first, last.) ! INCLUDE 'inputs.i' ! Variables 'from': ! 1. External_inputs - Character*80 string containing the name ! of the file which contains the external ! file inputs (source position, site ! position, etc. files) ! 2. External_aprioris - Logical variable controlling whether ! external a priori inputs will be looked ! for. If .FALSE., will not look for them. ! If .TRUE., will look for them. ! Variables 'to': ! 1. Ex_sites - File name for site info ! 2. Ex_stars - File name for stars (radio sources) info ! 3. Ex_ocean - File name for ocean loading info ! 4. Ex_EOP - File name for Earth orientation parameters ! 5. Ex_tilts - File name for antenna axis tilt parameters ! 6. Input_sites - T/F flag for using external site inputs ! 7. Input_stars - T/F flag for using external source inputs ! 8. Input_ocean - T/F flag for using external ocean loading ! 9. Input_EOP - T/F flag for using external EOP inputs ! 10. Input_tilts - T/F flag for using external tilt inputs ! Data Ex_sites /' & & '/ Data Ex_stars /' & & '/ Data Ex_ocean /' & & '/ Data Ex_EOP /' & & '/ Data Ex_tilts /' & & '/ Data Input_sites /.False./ Data Input_stars /.False./ Data Input_ocean /.False./ Data Input_EOP /.False./ Data Input_tilts /.False./ ! INCLUDE 'param.i' ! Variables from: ! 1. A_tilts - Antenna tilts file name (second priority) ! ! Real*8 ATMUTC(3), ROTEPH(2,20), A1UTC(3), A1DIFF(3) COMMON / EOPCM / ATMUTC, ROTEPH, A1UTC, A1DIFF ! VARIABLES 'TO': ! 1. ROTEPH(2,20)- The array which contains the epochs at which ! TAI - UT1 is desired. The entries are: ! 1) JD at 0:00 hours UTC, ! 2) The fraction of a UTC day from 0:00 hours ! to the desired epoch. ! Real*8 XCALC, FJLDY Integer*2 NFLAG,NFLAGC,loadm(8),LFILE(3) COMMON /STACM/ Computing_center,XCALC,NFLAG,NFLAGC,loadm,LFILE ! Integer*4 gethostname, ierr4 Integer*2 imode, ILU, iout, idd1 Character*64 Computing_center Character*6 C_LFILE Character*128 CALCON_NAME Character*75 Lhist1 Equivalence (C_LFILE,LFILE) ! ! Variables 'from': ! 1. loadm(8) - The load module compilation date message. ! 2. NFLAG - The total number of CALC flow control and debug flags. ! 3. LFILE(3) - The name of the CALC control file. ! 7. XCALC - The CALC version number. ! ! Program specifications - ! Real*8 JDY2K, JD1 Integer*4 Iyear, Imonth, Iday Integer*4 IFLAG(62) Integer*2 LCALC(40), LFCIO(40), LHIST(66), LNAME(5), LNAMO(5), & & IBUF(40), trimlen, host_len, hist_len Integer*4 Ipid, Getpid, jj, IOS Real*8 xleap(5), tol CHARACTER LNAME_chr*10, LNAMO_chr*10, LFCIO_chr*80, LHIST_chr*132 Character*8 Ich8 Character*80 Ich80 CHARACTER*80 CBUF,CTIME*12,CDATE*16 EQUIVALENCE ( IFLAG(1), KATMC ), ( LCALC(1), LHIST(1) ), & & ( IBUF, CBUF), (LNAME,LNAME_chr), & & ( LNAMO,LNAMO_chr), (LFCIO,LFCIO_chr), & & ( LHIST,LHIST_chr) Integer*2 IPAR(5), getunit, kruc, iveri, lfvo, isame, ivero, & & kerr, NDO(3), idd2 Integer*4 I, N, Unit1, Unit2, isz, iup, MXUTPM Character*80 xtlt Character*24 STR24 save Unit1, Unit2 CHARACTER*10 IPAR_C EQUIVALENCE (IPAR,IPAR_C) DATA KRUC / 2 / Data Lhist1 / & & ' & & '/ Data Unit1 /0/ ! ! Database access - The database is initialized by a call to subroutine ! KAI. Inserted into the database via subroutine PHIST is ! the CALC history text which consists of the CALC run ! title, the CALC run date, the CALC run time and the ! load module message. ! ! External I/O ! Input variables: ! 1. Non-default model module and utility routine flow control and ! debug output flags. ! 2. LCALC(40) - The CALC run title. ! 3. LNAME(5) - The database experiment file to be processed. ! 4. LNAMO(5) - The name of the output database. ! Output variables: ! 1. All model and module utility routine flow control and debug ! output flags. ! 2. LCALC(40) - The CALC run title. ! 3. STR24(24) - The date and time of the CALC run. ! 4. LDATI(5) - The creation date of the input database. ! 5. LFCIO(40) - The text descriptor from the input database. ! 6. LNAME(3) - The database experiment file to be processed. ! 7. LNAMO(5) - The name of the output database. ! ! Subroutine interface - ! Caller subroutines: MAIN ! Called subroutines: QUIT_CALC, UPPER, gethostname, trimlen, ! KAI, MVREC, GETI, PHIST, FDATE, OPEN, CLOSE, ! JDY2K, GETEOP ! ! Program variables - ! 1. IFLAG(NFLAG) - The variable used to initialize all flow ! control and debug output flags. ! 2. LHIST1(66) - The CALC history text. Included in the text ! are the CALC run title, the run date, the run ! time, and the load module message. ! 3. KERR - The database error return flag. ! 4. IVERI - The version number of the input database. ! 5. LFVO - The version number of the output database. ! 6. IBUF(40) - A buffer area for READF ! 7. Intrvl(5,2) - First and last UTC tag for data in the current ! data base. (First index - year(2 digits), ! month(1-12), day of month, hours, minutes) ! ! Programmer - Dale Markham 01/12/77 ! 77.07.07 Peter Denatale ! 78.05.11 Bruce Schupler ! 78.09.14 Bruce Schupler ! 78.05.12 Bruce Schupler ! 78.06.12 Bruce Schupler ! 80.01.07 Bruce Schupler ! 80.08.26 Bruce Schupler ! 84.07.12 David Gordon Pole Tide ! 85.01.08 David Gordon IDISC from RMPAR(3)) ! 85.02.17 David Gordon Fixed bug in purge statement. ! 87.06.02 Savita Goel CDS for A900. ! 89.05.22 Gregg Cooke CALC 7.0 MODS. ! 87.09.25 Jim Ryan Documentation simplified. ! 89.12.12 Jim Ryan UNIX-like database interface implimented. ! 90.02.03 Jim Ryan Removed from call to KAI. ! 90.02.09 Jim Ryan CALCON file logic modified to use CI and fmgr ! 90.11.26 Jim Ryan Upgraded to CALC 7.3. Improved history ! message added. OLD calcon_name logic for ! A900 lu's striped out. ! 91.05.10 Brent Archinal Upgraded to CALC 7.4Beta with change to ! ctheu.f to fix 'HELL EMS'. ! 91.05.28 Jim Ryan Documentation cleaned up furthur and output ! suppression fixed. ! 91.06.23 JWR History message improved and made machine ! independent. ! 92.11.13 JWR Getunit introduced to get a unique unit number ! 93.03.09 Brent Archinal Number of flags correctly set to 62. ! 94.04.15 David Gordon Converted to Implicit None. ! 94.06.08 David Gordon Corrected format statements, single and double ! quotes reversed. ! 94.06.27 David Gordon Changed to Calc 8.1. ! 95.11.13 B. Archinal Fixed spelling of "pleasant"! Also now properly ! handling error from gethostname. ! 98.03.13 D. Gordon Added include file inputs.i; mods for external ! file input of a priori's. ! 98.04.13 D. Gordon Added include files cmxst.i, cmxsr.i, and ! 'cmxut.i'. Added read-only data base open and ! GET's for number of sites, number of sources, ! and data interval. Other mods for external ! site and source a priori's input. ! 98.05.01 D. Gordon Added code to load rotation epoch array. Added ! subroutine GETEOP and other mods for external ! EOP input. ! 98.07.23 D. Gordon Replacing FJLDY calls with JDY2k calls for Y2k ! compliance. Will handle both 2-digit and 4-digit ! years. Removed ISECU, IDISC, and IOPEN from ! Common /STACM/. ! 98.10.13 D. Gordon Code cleanup. ZTIME calls replaced with FDATE. ! CDATE and CTIME replaced with STR24. ! 98.11.04 D. Gordon Put in code to use proposed new Lcode ! 'INTRVAL4', the start/stop interval ! (yr/month/day/hr/min) using a 4-digit year. If ! not there will use 'INTERVAL' (2-digit year). ! 99.10.01 D.Gordon Changed to version 9.1. ! 99.10.27 D.Gordon Extraneous printouts removed. ! 02 Sept Jim Ryan Integer*2/4 mods. ! 03.03.10 Jim Ryan Kill replaced with terminate_solve ! 04.05.13 D. Gordon Antenna fixed axis tilts apriori usage mods. ! ! START Program Structure ! ILUOUT = iout MXUTPM = 20 ! ! Open the CALC control file first time through (first database). If(Unit1 .eq. 0) Then ! First data base ! Unit1 = getunit() OPEN(Unit1,FILE=CALCON_NAME,STATUS='OLD', IOSTAT= IOS) IF(IOS.ne.0) then WRITE(6,147) CALCON_NAME 147 Format( & & ' Expected to find CALCON file as ',A,'. Not there!',//, & & ' The run string for CALC 10 is 0,IC,calcon,inputs where:',/, & & ' 1) 0 is a literal zero ',/, & & ' 2) IC is normally 0, but -1 to suppress screen output,',/, & & ' 3) calcon is the name with path of the calcon file,',/, & & ' 4) inputs is the optional name of the inputs file.',//, & & ' Quitting ') IPAR_C = 'CALC Fail ' CALL QUIT_CALC(IPAR) Endif ! ! Open external input file if present IF (External_aprioris) Then ! External aprioris !** print *, ' Using external a prioris ' Unit2 = getunit() Open(Unit2, File=External_inputs, Status='Old', Iostat=Ios) If(Ios .ne. 0) Then WRITE ( 6, * ) 'START/OPEN, IOS= ', Ios Endif ! 22 Continue Read(unit2,1530,end=23) Ich8, Ich80 1530 Format(a,a) ! Remove leading blanks and make all upper case isz = 8 iup = 1 Call Upper(isz, iup, Ich8) ! isz = 80 iup = 0 Call Upper(isz, iup, Ich80) ! print *,'Ich8, Ich80', Ich8, Ich80 If (Ich8(1:5) .eq. 'SITES') Ex_sites = Ich80 If (Ich8(1:7) .eq. 'SOURCES') Ex_stars = Ich80 If (Ich8(1:5) .eq. 'OCEAN') Ex_ocean = Ich80 If (Ich8(1:3) .eq. 'EOP') Ex_EOP = Ich80 If (Ich8(1:5) .eq. 'TILTS') Ex_tilts = Ich80 Go to 22 23 Continue Close(Unit2) If (Ex_sites(1:20) .eq. ' ') & & Ex_sites(1:4) = 'None' If (Ex_stars(1:20) .eq. ' ') & & Ex_stars(1:4) = 'None' If (Ex_ocean(1:20) .eq. ' ') & & Ex_ocean(1:4) = 'None' If (Ex_EOP(1:20) .eq. ' ') & & Ex_EOP(1:4) = 'None' If (Ex_tilts(1:20) .eq. ' ') & & Ex_tilts(1:4) = 'None' ! write(6,'("Ex_sites ",1x,A80)') Ex_sites write(6,'("Ex_stars ",1x,A80)') Ex_stars write(6,'("Ex_ocean ",1x,A80)') Ex_ocean write(6,'("Ex_EOP ",1x,A80)') Ex_EOP write(6,'("Ex_tilts ",1x,A80)') Ex_tilts ! If (Ex_sites(1:4) .ne. 'None') Input_sites = .True. If (Ex_stars(1:4) .ne. 'None') Input_stars = .True. If (Ex_ocean(1:4) .ne. 'None') Input_ocean = .True. If (Ex_EOP(1:4) .ne. 'None') Input_EOP = .True. If (Ex_tilts(1:4) .ne. 'None') Input_tilts = .True. ! ! print *, ' START/Inputs: ', Input_sites, Input_stars, ! * Input_ocean, Input_EOP, ! * Input_tilts ! Endif ! External aprioris ! ! Check for alternate tilt file input via param.i file IF (.Not. Input_tilts) THEN xtlt = A_tilts If (xtlt(1:4).ne.'None' .and. xtlt(1:4).ne.'NONE' & & .and. xtlt(1:4).ne.'none' .and. xtlt(1:4).ne.' ') & & Then Ex_tilts = A_tilts Input_tilts = .True. ! print *, 'Tilt file found in param.i' Endif ENDIF ! Endif ! First data base ! ! Input the CALC run title and the database experiment file to be processed, ! and the name of the output database. Obtain the date and time of the CALC ! run. If there is no more information in the control data set, skip on. ! READ(Unit1,'(40A2)',END=10000) LCALC READ(Unit1,'(5A2,I10,5X,5A2,I10)',END=10000) & & LNAME, IVERI, LNAMO, LFVO ! IF(LNAMO_chr .eq. ' ') then !Defaulting the output name LNAMO_chr = LNAME_chr LFVO = 0 Endif ! CALL FDATE (STR24) ! FDATE returns a 24 character string containing the time and date ! in the following form: 'Tue Oct 13 14:08:43 1998'. Previously this ! info was obtained with subroutine ZTIME. You may need to use the ! +U77 compile line option when compliling and linking. ! ! Write the CALC run title, the database experiment file to be processed, the ! date of the CALC run, the time of the CALC run, and the load module message. Ipid = Getpid() ierr4 = gethostname(computing_center) if(ierr4.ne.0) then ! WEW ! write(6,"('ERROR reading host computer name')") ! call perror() call perror( 'ERROR reading host computer name' ) endif host_len = trimlen(Computing_center) WRITE (6,9301) LCALC, LNAME, IVERI, LNAMO, LFVO, STR24, & & LOADM,xcalc,computing_center(1:host_len) 9301 FORMAT (/,1X,40A2,/,' Database experiment file: ',5A2,2X,I4, & & /,' Name of output file: ',5X,5A2,2X,I4,/, & & ' Date and time of CALC run: ', A24, & & /,1X,8A2,' CALC version ',f5.2,1x,a15) ! ! Initialize all flow control and debug output flags to zero. DO 400 N = 1, NFLAG 400 IFLAG(N) = 0 ! ! Read the non-default model module and utility routine flow control and ! debug flags. READ(Unit1,'(80I1)',END=10000) IFLAG ! ! Write the entire array of model module and utility routine flow ! control and debug flags. If(ILUOUT.ne.-1) WRITE ( 6,9400 ) IFLAG ! ! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ! If doing external a priori inputs, we must open the database in read-only ! mode, get the number of sites and sources and the data base interval, ! and then close the database. IF ( Input_sites .or. Input_stars .or. Input_ocean .or. & & Input_EOP .or. Input_tilts ) Then Call KAI (int2(1), int2(0), int2(0), int2(1), LNAME_chr, iveri, & & 'SAME', 'SAME', IVERO, LFCIO_chr, KERR) ! Get the header record Call MVREC (int2(1), int2(1), int2(1), kerr) If (kerr .ne. 0) Then write(6,'("START/MVREC: Kerr = ",i5)') Kerr CALL TERMINATE_CALC ('START ', int2(1), KERR) Endif ! Get number of sites, number of sources, Interval, EOP stuff If (Input_sites .or. Input_ocean .or. Input_tilts) & & CALL GETI ('# SITES ', NUMSIT, & & int2(1), int2(1), int2(1), NDO, KERR) If (Input_stars) CALL GETI ('# STARS ', NUMSTR, int2(1), & & int2(1), int2(1), NDO, KERR) ! ! If (Input_EOP .or. Input_tilts) Then If (Input_EOP) Then ! Get new 4-digit year access code CALL GETI ('INTRVAL4 ', Intrvl, int2(5), int2(2), & & int2(1), NDO, KERR) ! If not there, then get old 2-digit year access code If (KERR.ne.0) CALL GETI ('INTERVAL ', Intrvl, int2(5), & & int2(2), int2(1), NDO, KERR) ! Endif ! If (kerr.eq.0) Then ! New code, for Y2K compliance. Takes 2 or 4 digit years. Iyear = intrvl(1,1) Imonth = intrvl(2,1) Iday = intrvl(3,1) JD1 = JDY2K (Iyear, Imonth, Iday) xintv(1) = JD1 + & & intrvl(4,1)/24.D0 + intrvl(5,1)/1440.D0 ! Iyear = intrvl(1,2) Imonth = intrvl(2,2) Iday = intrvl(3,2) xintv(2) = JDY2K(Iyear, Imonth, Iday) + & & intrvl(4,2)/24.D0 + intrvl(5,2)/1440.D0 ! ! Get the UT1 and polar motion external input values Call GETEOP ! ! Load the rotation epoch array. Ndays = 2 ROTEPH(1,1) = JD1 ! If((intrvl(4,1).eq.0) .and. (intrvl(5,1).eq.0)) & & ROTEPH(1,1) = ROTEPH(1,1) - 1.D0 ROTEPH(2,1) = xintv(1) - ROTEPH(1,1) - 1.D0/1440.D0 Do While (ndays.le.MXUTPM .and. & & (ROTEPH(1,ndays-1)+1.D0).le.xintv(2)) ROTEPH(1,ndays) = ROTEPH(1,ndays-1) + 1 ROTEPH(2,ndays) = 0.D0 Ndays = ndays + 1 Enddo Ndays = ndays - 1 ! Else Xintv(1) = 9.9D99 Xintv(2) = -9.9D99 Endif Endif ! ! Close the database Call FINIS( int2(0)) !---------------------------------------------------------- ELSE Call KAI (int2(1), int2(0), int2(0), int2(1), LNAME_chr, iveri, & & 'SAME', 'SAME', IVERO, LFCIO_chr, KERR) Call MVREC( int2(1), int2(1), int2(1), kerr) If (kerr .ne. 0) Then write(6,'("START/MVREC: Kerr = ",i5)') Kerr CALL TERMINATE_CALC ( 'START ', int2(1), KERR) Endif ! Get number of sites, number of sources, Interval, EOP stuff CALL GETI ( '# SITES ', NUMSIT, & & int2(1), int2(1), int2(1), NDO, KERR) Call FINIS( int2(0)) !---------------------------------------------------------- ENDIF ! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ! ! Initialize the database in update mode. ! In order to get around a quirk in the database catalog, we need to ! test to see if the input and output keys are the same. ISAME = 0 IF(LNAME_chr .eq. LNAMO_chr) ISAME = 1 IF(ISAME .EQ. 0) CALL KAI (KRUC, int2(0), int2(0), int2(1), & & LNAME_chr, IVERI, LNAMO_chr, 'SAME', IVERO, LFCIO_chr, KERR) ! IF(ISAME .EQ. 1) CALL KAI (KRUC, int2(0), int2(0), int2(1), & & LNAME_chr, IVERI, 'SAME', 'SAME', IVERO, LFCIO_chr, KERR) ! ! Check for interfacing errors with the database. If an error, then ! TERMINATE_CALC CALC and terminiate. IF (KERR .NE. 0) CALL TERMINATE_CALC ('START ', int2(1), KERR) ! ! Insert two history records. Write(Lhist1,'( "CALC",f5.2,1x,8a2,1x,a24,a10)') & & xcalc,(loadm(jj),jj=1,8),STR24, computing_center(1:host_len) hist_len = trimlen(lhist1) CALL PHIST (hist_len, Lhist1) CALL PHIST ( int2(132), LHIST_chr) ! ! Check for debug printout. IF(KSTAD .NE. 0) THEN WRITE(6,'("Debug output from subroutine START")') WRITE(6,'("LFILE = ",3A2)') LFILE ENDIF ! ! Normal conclusion. RETURN ! 9400 FORMAT (1X, 'KATMC =', I2, 3X, 'KATMD =', I2, 3X, & & 'KAXOC =', I2, 3X, 'KAXOD =', I2, 3X, 'KPTDC =', I2, 3X, & & 'KPTDD =', I2, /, ' KDNPC =', I2, 3X, 'KDNPD =', I2, 3X, & & 'KETDC =', I2, 3X, 'KETDD =', I2, 3X, 'KIONC =', I2, 3X, & & 'KIOND =', I2, /, ' KNUTC =', I2, 3X, 'KNUTD =', I2, 3X, & & 'KPREC =', I2, 3X, 'KPRED =', I2, 3X, 'KRELC =', I2, 3X, & & 'KRELD =', I2, /, ' KSITC =', I2, 3X, 'KSITD =', I2, 3X, & & 'KSTRC =', I2, 3X, 'KSTRD =', I2, 3X, 'KUT1C =', I2, 3X, & & 'KUT1D =', I2, /, ' KWOBC =', I2, 3X, 'KWOBD =', I2, /, & & ' KUTCC =', I2, 3X, 'KUTCD =', I2, 3X, 'KATIC =', I2, 3X, & & 'KATID =', I2, 3X, 'KCTIC =', I2, 3X, 'KCTID =', I2, /, & & ' KPEPC =', I2, 3X, 'KPEPD =', I2, 3X, 'KDIUC =', I2, 3X, & & 'KDIUD =', I2, 3X, 'KM20C =', I2, 3X, 'KM20D =', I2, /, & & ' KROSC =', I2, 3X, 'KROSD =', I2, 3X ,'KSTEC =', I2, 3X, & & 'KSTED =', I2, 3X, 'KSUNC =', I2, 3X, 'KSUND =', I2, /, & & ' KSARC =', I2, 3X, 'KSARD =', I2, 3X, 'KTHEC =', I2, 3X, & & 'KTHED =', I2, 3X, 'KMATC =', I2, 3X, 'KMATD =', I2, /, & & ' KVECC =', I2, 3X, 'KVECD =', I2, 3X, 'KOCEC =', I2, 3X, & & 'KOCED =', I2, 3X, 'KASTC =', I2, 3X, 'KASTD =', I2, /, & & ' KSTAC =', I2, 3X, 'KSTAD =', I2, 3X, 'KPLXC =', I2, 3X, & & 'KPLXD =', I2, 3X, 'KPANC =', I2, 3X, 'KPAND =', I2) ! ! Here we tell the user that all requests are done. Also send a parameters ! array back to the scheduling program saying that CALC terminated normally. ! 10000 CONTINUE CLOSE(Unit1) 10110 CONTINUE IF (ILUOUT.NE.-1) WRITE(6,'(/, & & " All requested databases have been processed.",/, & & " CALC",f5.2," thanks you and hopes you have a pleasant day.")') & & xcalc IPAR_C = 'CALC 10 OK' CALL QUIT_CALC(IPAR) END !********************************************************************** BLOCK DATA STACMB IMPLICIT None ! ! 1. STABD ! ! 1.1.1 STABD IS THE BLOCK DATA INITIALIZATION SECTION FOR THE START MODULE. ! IT HOLDS THE LOAD MODULE DATE MESSAGE. ! ! 1.2.2 COMMON BLOCKS USED Real*8 XCALC Integer*2 NFLAG,NFLAGC,loadm(8),LFILE(3) COMMON /STACM/ Computing_center,XCALC,NFLAG,NFLAGC,loadm,LFILE Character*64 Computing_center CHARACTER*16 LOADM_CHR EQUIVALENCE (LOADM,LOADM_CHR) CHARACTER*6 C_LFILE EQUIVALENCE (C_LFILE,LFILE) ! ! VARIABLES 'TO': ! 1. LOADM - THE LOAD MODULE COMPILATION DATE MESSAGE. ! 2. NFLAG - THE TOTAL NUMBER OF CALC FLOW CONTROL AND DEBUG FLAGS. ! 3. LFILE(3) - THE NAME OF THE CALC CONTROL FILE. ! 4. XCALC - THE CALC PROGRAM VERSION NUMBER. ! DATA LOADM_CHR /'Ver. 2006.04.03 '/ DATA NFLAG /62/ DATA C_LFILE /'CALCON'/ DATA XCALC/10.0D0/ ! ! 1.2.9 PROGRAMMER - BRUCE SCHUPLER 05/12/78 ! BRUCE SCHUPLER 06/05/78 ! BRUCE SCHUPLER 09/14/78 ! BRUCE SCHUPLER 12/06/78 ! BRUCE SCHUPLER 06/06/79 ! BRUCE SCHUPLER 08/26/80 ! DAVID GORDON 06/19/84 ! DAVID GORDON 01/08/85 (REMOVED IDISC=59) ! SAVITA GOEL 06/02/87 (CDS FOR A900) ! Jim Ryan 89.07.25 Documentation simplified. ! Jim Ryan 89.12.12 UNIX-like database interface ! implimented. ! David Gordon 94.04.15 Converted to Implicit None ! David Gordon 98.07.23 Removed ISECU, IDISC, and IOPEN ! from Common /STACM/. END !********************************************************************** SUBROUTINE STAA() IMPLICIT None ! ! 1. STAA ! ! 1.1.1 STAA will do the ADDS to the database to provide for PUT'ing the CALC ! flow control flag names and values into the database. STAA also places ! the current version number of CALC into the database. ! ! 1.2 STAA PROGRAM INTERFACE ! ! 1.2.1 CALLING SEQUENCE - CALL STAA ! ! 1.2.2 COMMON BLOCKS USED - ! Real*8 XCALC Integer*2 NFLAG,NFLAGC,loadm(8),LFILE(3) Character*64 Computing_center COMMON /STACM/ Computing_center,XCALC,NFLAG,NFLAGC,loadm,LFILE ! ! VARIABLES 'FROM' - ! 1) NFLAG - THE TOTAL NUMBER OF CALC FLOW CONTROL AND DEBUG FLAGS. ! VARIABLES 'TO' - ! 1) NFLAGC - THE NUMBER OF CALC FLOW CONTROL FLAGS (= NFLAG / 2). ! ! 1.2.3 PROGRAM SPECIFICATIONS - NONE ! ! 1.2.4 DATA BASE ACCESS - ! ACCESS CODES - ! 1) 'CALCFLGN' - THE DATA BASE ACCESS CODE FOR THE ARRAY OF THE CALC FLOW ! CONTROL FLAG NAMES. ! 2) 'CALCFLGV' - THE DATA BASE ACCESS CODE FOR THE ARRAY OF CALC FLOW ! CONTROL FLAG VALUES. ! 3) 'CALC VER' - THE DATA BASE ACCESS CODE FOR THE CURRENT VERSION NUMBER ! OF PROGRAM CALC. ! ! 1.2.5 EXTERNAL INPUT/OUTPUT - NONE ! ! 1.2.6 SUBROUTINE INTERFACE - ! CALLER SUBROUTINES - TOCUP ! CALLED SUBROUTINES - ADDA,ADDI,ADDR ! ! 1.2.9 PROGRAMMER - BRUCE SCHUPLER 09/14/78 ! DAVID GORDON 06/19/84 ! Jim Ryan 89.07.25 Documentation simplified. ! Jim Ryan 89.12.12 UNIX-like database interface ! implimented. ! David Gordon 94.04.15 Converted to Implicit None ! David Gordon 98.07.23 Removed ISECU, IDISC, and IOPEN ! from Common /STACM/. ! Jim Ryan 2002 Sept Integer*2/4 mods. ! ! STAA Program Structure ! ! Compute NFLAGC NFLAGC = NFLAG / 2 ! ! Do the ADD for the flag names CALL ADDA (int2(1),'CALCFLGN','CALC flow control flags name def', & & int2(2), NFLAGC, int2(1)) ! ! Do the ADD for the flag values CALL ADDI (int2(1),'CALCFLGV','CALC flow control flags valu def', & & NFLAGC, int2(1), int2(1)) ! ! Do the ADD for the CALC version number CALL ADDR (int2(1),'CALC VER','CALC version number ', & & int2(1), int2(1), int2(1)) ! RETURN END !********************************************************************** SUBROUTINE STAI() IMPLICIT None ! ! 1. STAI ! ! 1.1.1 STAI is the routine which will PUT the CALC control flag names and ! values and the CALC version number into the database. ! ! 1.2.2 COMMON BLOCKS USED - ! INCLUDE 'ccon.i' ! VARIABLES 'FROM' - ! 1) IFLAG(62) - THE ARRAY OF CALC DEBUG AND CONTROL FLAGS. ! Real*8 XCALC Integer*2 NFLAG,NFLAGC,loadm(8),LFILE(3) Character*64 Computing_center COMMON /STACM/ Computing_center,XCALC,NFLAG,NFLAGC,loadm,LFILE ! VARIABLES 'FROM' - ! 1) NFLAG - THE TOTAL NUMBER OF CALC DEBUG AND CONTROL FLAGS. ! 2) NFLAGC - THE NUMBER OF CALC CONTROL FLAGS. ! ! 1.2.3 PROGRAM SPECIFICATIONS ! INTEGER*4 IFLAG(62), I, J INTEGER*2 LFLAGC(2,31), IFLAGC(31), idm7 CHARACTER*4 C_LFLAGC(31) EQUIVALENCE (IFLAG(1),KATMC), (C_LFLAGC,LFLAGC) ! DATA C_LFLAGC / & & 'ATMC','AXOC','PTDC','DNPC','ETDC','IONC', & & 'NUTC','PREC','RELC','SITC','STRC','UT1C', & & 'WOBC','UTCC','ATIC','CTIC','PEPC','DIUC', & & 'M19C','ROSC','STEC','SUNC','SARC','THEC', & & 'MATC','VECC','OCEC','ASTC','STAC','PLXC', & & 'PANC'/ ! ! 1.2.4 DATA BASE ACCESS ! ACCESS CODES - ! 1) 'CALCFLGN ' - THE DATA BASE ACCESS CODE FOR THE ARRAY ! OF CALC CONTROL FLAG NAMES. ! 2) 'CALCFLGV ' - THE DATA BASE ACCESS CODE FOR THE ARRAY OF ! CALC CONTROL FLAG VALUES. ! 3) 'CALC VER ' - THE DATA BASE ACCESS CODE FOR THE CURRENT ! CALC VERSION NUMBER. ! 'PUT' VARIABLES - ! 1) LFLAGC(2,31) - THE ARRAY OF CALC CONTROL FLAG NAMES. ! 2) IFLAGC(31) - THE ARRAY OF CALC CONTROL FLAG VALUES. ! 3) XCALC - THE CALC VERSION NUMBER (REAL NUMBER). ! ! 1.2.6 SUBROUTINE INTERFACE ! CALLER SUBROUTINES - INITAL ! CALLED SUBROUTINES - PUTA,PUTI,PUT4 ! ! 1.2.9 PROGRAMMER - BRUCE SCHUPLER 09/18/78 ! BRUCE SCHUPLER 01/09/80 ! BRUCE SCHUPLER 08/26/80 ! DAVID GORDON 06/19/84 (VERSION #) ! DAVID GORDON 07/12/84 (POLE TIDE) ! DAVID GORDON 01/14/86 (IFLAG & OTHER DIMENSIONS FIXED) ! SAVITA GOEL 06/02/87 (CDS FOR A900) ! Jim Ryan 89.07.26 Documentation simplified. ! Jim Ryan 89.12.12 UNIX-like database interface ! implimented. ! David Gordon 94.04.15 Converted to Implicit None ! David Gordon 98.07.23 Removed ISECU, IDISC, and IOPEN ! from Common /STACM/. ! Jim Ryan 2002 Sept Integer*2/4 mods. ! ! STAI Program Structure ! ! Copy the control flag from IFLAG to IFLAGC J = 0 DO 100 I=1,NFLAG,2 J = J + 1 IFLAGC(J) = IFLAG(I) 100 CONTINUE ! ! PUT the flag values. CALL PUTI ('CALCFLGV ', IFLAGC, NFLAGC, int2(1), int2(1)) ! ! PUT the flag names. CALL PUTA ('CALCFLGN ', LFLAGC, int2(2), NFLAGC, int2(1)) ! ! PUT the CALC version number. CALL PUT4 ('CALC VER ', XCALC, int2(1), int2(1), int2(1)) ! ! Check for debug output. IF(KSTAD .NE. 1) GO TO 1000 WRITE(6,200) 200 FORMAT(1X,'Debug output from subroutine STAI') WRITE(6,220) NFLAG,NFLAGC 220 FORMAT(1X,'NFLAG = ',I5,5X,'NFLAGC = ',I5) WRITE(6,230) IFLAG 230 FORMAT(1X,'IFLAG = ',31I2,/,9X,31I2) WRITE(6,240) IFLAGC 240 FORMAT(1X,'IFLAGC =' ,10I5,/, 9X,10I5,/, 9X,10I5) WRITE(6,250) LFLAGC 250 FORMAT(1X,'LFLAGC = ',10(2A2,1X),/,10X,10(2A2,1X), & & /,10X,10(2A2,1X)) ! 1000 CONTINUE RETURN END !********************************************************************** Subroutine Upper(Isize, Iup, String) Implicit None ! ! Subroutine to remove leading blanks in a character string and convert all ! letters to upper case. ! ! Input: ! Isize = Number of characters ! Iup = 0 ==> Don't convert to upper case ! Iup = 1 ==> Do convert to upper case ! Input/Output: ! String = The character string ! ! Programmer: ! 98.03.13 David Gordon Original program written ! Integer*4 Isize, I, J, Icnt, Iup Character*(*) String Character*26 Upper_case, Lower_case Data Upper_case /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ Data Lower_case /'abcdefghijklmnopqrstuvwxyz'/ ! Icnt = 0 ! !** write(6,'(i4,2x,a)') Isize, String ! ! Get rid of leading blanks 20 Continue Icnt = Icnt + 1 If (Icnt .ge. Isize) Return If (String(1:1) .eq. ' ') Then Do J=2,Isize String(J-1:J-1) = String(J:J) Enddo String(Isize:Isize) = ' ' Go to 20 Endif ! ! Special case, 'None', 'NONE', 'none', etc. If (String(1:4) .eq. 'NONE') String(1:4) = 'None' If (String(1:4) .eq. 'none') String(1:4) = 'None' ! If (Iup .ne. 1) Return ! Make all letters upper case Do J=1,Isize Do I=1,26 If (String(J:J) .eq. Lower_case(I:I)) Then String(J:J) = Upper_case(I:I) Go to 30 Endif Enddo 30 Continue Enddo ! Return End !********************************************************************** SUBROUTINE GETEOP() Implicit None ! ! Get Earth orientation table from an external file. ! This routine reads a SOLVE-format EOP Mod file. ! ! Common blocks used - ! INCLUDE 'inputs.i' ! Variables 'from': ! 1. Ex_EOP - File name of the external EOP input file ! INCLUDE 'cmxut.i' ! Variables 'from': ! 1. Xintv(2) - First and last Julian Date in the data base ! Variables 'to': ! 1. UT1IF(4) - The final UT1 information array. This array ! contains respectively: 1) The Julian date of the ! first tabular point, 2) The increment in days of ! the tabular points, 3) The number of tabular ! points, 4) The units of the UT1 tabular array per ! second. (days, days, unitless, sec/table unit) ! 2. UT1PT(20) - The tabular values of 'TAI minus UT1'. ! (table units) ! 3. ISHRTFL - The short period tidal terms flag, (unitless). ! = 1 --> UT1 table coming from input database is ! true UT1, (that is, fortnightly tidal terms have ! not been removed, as in the IRIS or IERS series). ! = -1 --> UT1 table coming from input database is ! UT1R, (that is, the Yoder fortnightly tidal terms ! HAVE been removed as in Bulletin B). ! = -2 --> UT1 table coming from input database is ! UT1S, (the S tidal terms HAVE been removed). ! 4. Leap_fix - Used in external input mode. .True. means ! correct the input EOP series for accumluated ! leap seconds. .False. means do not correct. ! 5. UT1type - UT1 data type: 'UT1-TAI ' or 'UT1-UTC '. ! For ''UT1-UTC ', leap second corrections ! must be made. ! 6. EOP_time_scale - EOP table time scale, allowed values: ! 'TAI ', 'TCG ', 'TDB ', ! 'TDT ', 'UTC ', 'UNDEF '. ! Assumed default if not present => TDB ! INCLUDE 'cmwob.i' ! Variables 'to': ! 1. WOBIF(3) - The wobble information array. Contains ! respectively: 1) The Julian date of the first ! tabular point, 2) The increment in days of the ! tabular points, 3) The number of tabular points. ! (days, days, unitless) ! 2. XYWOB(2,20)- The wobble tabular points for the polar motion ! (wobble) X & Y offsets. (milliarcsec) ! (Note: Based on old BIH conventions, offsets ! are assumed to be left-handed.) ! ! Program Specifications - Integer*2 Getunit, KERR, idd3 Integer*4 Iunit, Npts, Nerp, I, IOS Character*4 Utflag Character EOP_ID*15, dummy1*1 Real*8 JD1, Uintv, Xmjdm, Mjdm, Mjds, Xmjds, XJDT, X10, Y10, & & UT1T, Xmjdl, JD2 ! ! Program variables: ! JD1 - First (full) Julian Day in EOP file ! JD2 - Last (full) Julian Day in EOP file ! Uintv - EOP interval (usually 1.0 days) ! Npts - Number of points in the input EOP file ! Nerp - Number of trabular points to use in the UT1 and polar ! motion interpolation tables ! Utflag - Type of UT1 data (UT1, UT1R, UT1S) ! Xmjdm - Experiment midpoint (FJD) ! Mjdm - Experiment midpoint (MJD) ! Mjds - Time of first tabular point (MJD) ! Xmjds - Time of first tabular point (FJD) ! Xmjdl - Time of last tabular point (FJD) ! ! Programmer: ! 98.04.27 David Gordon - Original program written ! 99.11.19 David Gordon - Bug fix, CLOSE(Iunit) statements added. ! 99.11.23 David Gordon - Setting number of EOP points to 15 always, ! for compatability with Dbedit/Apriori and ! SOLVE. ! 2000.12.11 David Gordon - Modify to skip comment statements in EOP ! mod file. ! 2000.12.29 David Gordon - Modify to read/interpret new EOP mod file ! table header record. !----------------------------------------------------------------------- ! Leap_fix = .False. ! ! Open the EOP file ! Iunit = Getunit() ! WEW ! OPEN (unit=Iunit, file=Ex_EOP, status='old', Readonly, err=99, & ! & Iostat=Ios) OPEN (unit=Iunit, file=Ex_EOP, status='old', err=99, & & Iostat=Ios) Go to 101 99 Continue Write(6,'(" Error opening external EOP file. Quitting! ")') Call TERMINATE_CALC ( 'GETEOP', int2(1), Ios) 101 Continue ! ! Read new EOP mod file format. 2000.12.29 Read(Iunit,1016,err=88) EOP_ID, JD1, Uintv, Npts, UT1type, & & EOP_time_scale 1016 Format (A15,2X,F9.1,2X,F4.1,2X,I5,2X,A8,2X,A8) ! If (UT1type .eq. 'UT1-TAI ') Then ! Normal case Utflag = 'UT1 ' ISHRTFL = 1 Leap_fix = .False. Go to 102 Endif ! Normal case ! If (UT1type .eq. 'UT1-UTC ') Then ! Abnormal case Utflag = 'UT1 ' ISHRTFL = 1 ! Will need to subtract leap seconds later (in UT1I) Leap_fix = .True. Go to 102 Endif ! Abnormal case ! ! If here, UT1type not properly defined. ????? Write(6,'(" Illegal UT1type in EOP mod file! Quitting! ")') Call TERMINATE_CALC ( 'GETEOP', int2(1), Ios) ! 88 Continue ! Old format, just in case Backspace (Iunit) Read(Iunit,1018, err=89) JD1, Uintv, Npts, Utflag 1018 Format (F9.1, F4.0, I4, 1X, A4) Write(6,'(/," !!! Using old EOP mod file format !!!",/)') ! Leap_fix = .False. UT1type = 'UT1-TAI ' EOP_time_scale = 'UNDEF ' ! Determine what the short period tidal term flag should be IF(Utflag .eq. 'UT1 ') ISHRTFL = 1 IF(Utflag .eq. 'UT1S') ISHRTFL = -2 IF(Utflag .eq. 'UT1R') Then ISHRTFL = -1 Write(6,'(" Cannot use UT1R data! Quitting! ")') Call TERMINATE_CALC ('GETEOP', int2(1), Ios) ENDIF ! !** Write(6,'(" ISHRTFL = ",I3)') ISHRTFL Go to 102 89 Continue Write(6,'(" Cannot read EOP file! Quitting! ")') Call TERMINATE_CALC ('GETEOP', int2(1), Ios) ! 102 Continue ! ! Number of points in table. Set to 15 when data interval less than 2.0 days. ! Increase by 1 for each additional day, up to 20 points. Nerp = 15 ! Set to 15 in all cases! 99.11.23 -DG- !* Nerp = 14 + (xintv(2)-xintv(1)) !* If (Nerp .lt. 15) Nerp = 15 !* If (Nerp .gt. 20) Nerp = 20 ! ! Midpoint of experiment Xmjdm = (Xintv(1) + Xintv(2)) / 2.D0 ! First tabular point at midnight prior to (Nerp*Uintv)/2 days before midpoint Mjdm = Xmjdm - 2400000.5D0 Mjds = Dint (Mjdm - (Nerp*Uintv)/2.D0) ! First point at time Xmjds: Xmjds = Mjds + 2400000.5D0 ! ! Check if EOP file does not start early enough: ! !! Require 15 points in all cases!!! 99.11.23 -DG- If (Xmjds .lt. JD1) Then !* Need at least one point before first observation time in data base !* If ( (Xintv(1) - Uintv) .lt. JD1 ) Then Write(6,'("GETEOP: Not enough EOP points before database")') KERR = 0 Close (Iunit) CALL TERMINATE_CALC ('GETEOP', int2(1), KERR) !* Else !* Recompute Nerp and reset first tabular point to JD1 !* Nerp = Nerp - (JD1-Xmjds+.01)/Uintv !* Xmjds = JD1 !* Endif Endif ! ! Check if EOP file ends too early: ! !! Require 15 points in all cases!!! 99.11.23 -DG- Xmjdl = Xmjds + (Nerp-1)*Uintv JD2 = JD1 + (Npts-1)*Uintv If (Xmjdl .gt. JD2) Then !* Need at least one point after last observation time in data base !* If ( (Xintv(2) + Uintv) .gt. JD2 ) Then Write(6,'("GETEOP: Not enough EOP points after database")') KERR = 0 Close (Iunit) CALL TERMINATE_CALC ('GETEOP', int2(1), KERR) !* Else ! Recompute Nerp !* Nerp = Nerp - ( Xmjdl-JD2+.01)/Uintv !* Endif Endif ! ! Write(6,1021) Xintv, Xmjdm, Mjdm, Mjds, Xmjds !1021 Format ('Xintv(2), Xmjdm, Mjdm, Mjds, Xmjds: ',2F20.8,/,5X, ! * 4F19.8) ! ! Fill the UT1 and Wobble information arrays UT1IF(1) = Xmjds UT1IF(2) = Uintv UT1IF(3) = Nerp UT1IF(4) = 1.0D0 !** Write(6,'(" UT1IF(4) ",4F15.6)') UT1IF ! WOBIF(1) = Xmjds WOBIF(2) = Uintv WOBIF(3) = Nerp !** Write(6,'(" WOBIF(3) ",3F15.6)') WOBIF ! ! Get the EOP points: ! Read till first point found 50 Continue Read (Iunit,*,err=50) XJDT, X10, Y10, UT1T ! Read (Iunit,1019) XJDT, X10, Y10, UT1T 1019 Format (F9.1, 2F8.4, I10) ! If (DABS(XJDT - XMJDS) .le. 1.D-8) Then Backspace (Iunit) Go to 70 Else Go to 50 Endif ! 70 Continue Do I = 1,Nerp ! Read (Iunit,1019) XJDT, X10, Y10, UT1T Read (Iunit,*) XJDT, X10, Y10, UT1T ! Input units are : X/Y => 0.1 arc-sec; UT1 => microseconds ! Convert to milli-arc-seconds and time seconds, and change ! UT1-TAI to TAI-UT1 (or UT1-UTC to UTC-UT1) UT1PT(I) = -UT1T/1.D6 XYWOB(1,I) = X10/10.D0 * 1.D3 XYWOB(2,I) = Y10/10.D0 * 1.D3 ! Enddo ! Write (6,1023) (XYWOB(1,I), XYWOB(2,I), UT1PT(I), I=1,Nerp) !1023 Format (' External EOPs: ',20(/,3F20.10)) ! Close(Iunit) ! Return End !********************************************************************** REAL*8 FUNCTION JDY2K (IYEAR, IMONTH, IDAY) Implicit None ! ! Function JDY2K: Function to convert year, month, day to full Julian ! day. The year can be either a four-digit year or a two-digit year. ! ! If a 4-digit year, this function is good from 1 March 1900 to 31 ! December 2099. ! ! If a 2-digit year, this function is good from 1 January 1970 to ! 31 December 2069. If year is 70 - 99, 1900 is added. If year is ! 00 - 69, 2000 is added. ! ! Programmer: ! 98.07.23 D. Gordon Function written from code in cutcu.f ! Integer*4 IYEAR, IMONTH, IDAY, IY, IM, ID ! IY = IYEAR IM = IMONTH ID = IDAY ! If (IY .ge. 70 .and. IY .le. 99) Then IY = IY + 1900 Go To 100 Endif ! If (IY .ge. 0 .and. IY .le. 69) Then IY = IY + 2000 Go To 100 Endif ! If (IY .gt.1900 .and. IY .le. 2099) Then Go To 100 Endif ! ! Year out of range if we get here Print *, ' JDY2K, Year out of Range, Stopping! ', IY Stop ! 100 Continue ! JDY2K = 367.D0*IY - (7 * ( IY + (IM+9)/12) )/4 + & & (275*IM)/9 + ID + 1721013.5D0 ! ! Write(6,1000) IYEAR, IMONTH, IDAY, IY, IM, ID, JDY2k 1000 Format(/,'Function JDY2K: ',/,' Input, Modified Y,M,D: ', & & 2x,3I5,5x,3I5,/,' JDY2K ', F15.2) Return End