/[PAMELA software]/DarthVader/OrbitalInfo/src/igrf_sub.for
ViewVC logotype

Diff of /DarthVader/OrbitalInfo/src/igrf_sub.for

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.8 by mocchiut, Thu Jan 16 15:29:26 2014 UTC revision 1.12 by mocchiut, Mon Jan 19 12:32:13 2015 UTC
# Line 1  Line 1 
1  c        subroutine igrf_sub(xlat,xlong,year,height,  C
 c     &          xl,icode,dip,dec)  
 c----------------------------------------------------------------  
 c   INPUT:  
 c     xlat     geodatic latitude in degrees  
 c     xlong    geodatic longitude in degrees  
 c     year     decimal year (year+month/12.0-0.5 or year+day-of-year/365  
 c          or 366 if leap year)  
 c     height     height in km  
 c   OUTPUT:  
 c     xl     L value  
 c     icode     =1  L is correct; =2  L is not correct;  
 c          =3  an approximation is used  
 c     dip     geomagnetic inclination in degrees  
 c     dec     geomagnetic declination in degress  
 c----------------------------------------------------------------  
 c  
 c      REAL              LATI,LONGI  
 c      COMMON/GENER/     UMR,ERA,AQUAD,BQUAD  
 c      SAVE /GENER/  
 C  
 c      CALL INITIZE  
 c      ibbb=0  
 c      ALOG2=ALOG(2.)  
 c      ISTART=1  
 c        lati=xlat  
 c        longi=xlong  
 c  
 C----------------CALCULATE PROFILES-----------------------------------  
 c  
 c        CALL FELDCOF(YEAR,DIMO)  
 c        CALL FELDG(LATI,LONGI,HEIGHT,BNORTH,BEAST,BDOWN,BABS)  
 c        CALL SHELLG(LATI,LONGI,HEIGHT,DIMO,XL,ICODE,BAB1)  
 c        DIP=ASIN(BDOWN/BABS)/UMR  
 c      DEC=ASIN(BEAST/SQRT(BEAST*BEAST+BNORTH*BNORTH))/UMR  
 c      RETURN  
 c      END  
 c  
 c  
2  C SHELLIG.FOR, Version 2.0, January 1992  C SHELLIG.FOR, Version 2.0, January 1992
3  C  C
4  C 11/01/91-DKB- SHELLG: lowest starting point for B0 search is 2    C 11/01/91-DKB- SHELLG: lowest starting point for B0 search is 2  
# Line 55  C*************************************** Line 17  C***************************************
17  C  C
18  C  C
19        SUBROUTINE FINDB0(STPS,BDEL,VALUE,BEQU,RR0)        SUBROUTINE FINDB0(STPS,BDEL,VALUE,BEQU,RR0)
       IMPLICIT REAL(8)(A-H)  
       IMPLICIT REAL(8)(O-Z)  
20  C--------------------------------------------------------------------  C--------------------------------------------------------------------
21  C FINDS SMALLEST MAGNETIC FIELD STRENGTH ON FIELD LINE  C FINDS SMALLEST MAGNETIC FIELD STRENGTH ON FIELD LINE
22  C  C
# Line 72  C          BEQU   MAGNETIC FIELD STRENGT Line 32  C          BEQU   MAGNETIC FIELD STRENGT
32  C          RR0    EQUATORIAL RADIUS NORMALIZED TO EARTH RADIUS  C          RR0    EQUATORIAL RADIUS NORMALIZED TO EARTH RADIUS
33  C          BDEL   FINAL ACHIEVED ACCURACY  C          BDEL   FINAL ACHIEVED ACCURACY
34  C--------------------------------------------------------------------  C--------------------------------------------------------------------
       REAL(8) P  
35        DIMENSION         P(8,4),SP(3)        DIMENSION         P(8,4),SP(3)
36        LOGICAL           VALUE        LOGICAL           VALUE
37        COMMON/FIDB0/     SP        COMMON/FIDB0/     SP
# Line 157  C        DO 1111 I=1,8 Line 116  C        DO 1111 I=1,8
116  C  C
117  C  C
118        SUBROUTINE SHELLG(GLAT,GLON,ALT,DIMO,FL,ICODE,B0)        SUBROUTINE SHELLG(GLAT,GLON,ALT,DIMO,FL,ICODE,B0)
       IMPLICIT REAL(8)(A-H)  
       IMPLICIT REAL(8)(O-Z)  
119  C--------------------------------------------------------------------  C--------------------------------------------------------------------
120  C CALCULATES L-VALUE FOR SPECIFIED GEODAETIC COORDINATES, ALTITUDE  C CALCULATES L-VALUE FOR SPECIFIED GEODAETIC COORDINATES, ALTITUDE
121  C AND GEMAGNETIC FIELD MODEL.  C AND GEMAGNETIC FIELD MODEL.
# Line 195  C                          WHICH ACCURAT Line 152  C                          WHICH ACCURAT
152  C                          APPROXIMATION IS USED.  C                          APPROXIMATION IS USED.
153  C          B0           MAGNETIC FIELD STRENGTH IN GAUSS  C          B0           MAGNETIC FIELD STRENGTH IN GAUSS
154  C-----------------------------------------------------------------------  C-----------------------------------------------------------------------
       REAL(8) AQUAD,BQUAD,ERA  
       REAL(8) CT,ST,D,ALT,X,RQ,P,U,STEP  
155        DIMENSION         V(3),U(3,3),P(8,100),SP(3)        DIMENSION         V(3),U(3,3),P(8,100),SP(3)
156        COMMON            X(3),H(196)        COMMON            X(3),H(196)
157        COMMON/FIDB0/     SP        COMMON/FIDB0/     SP
158        SAVE /FIDB0/        SAVE /FIDB0/
159        COMMON/GENER/     ERA,AQUAD,BQUAD,UMR        COMMON/GENER/     UMR,ERA,AQUAD,BQUAD
160        SAVE /GENER/        SAVE /GENER/
161          REAL FLS
162  C  C
163  C-- RMIN, RMAX ARE BOUNDARIES FOR IDENTIFICATION OF ICODE=2 AND 3  C-- RMIN, RMAX ARE BOUNDARIES FOR IDENTIFICATION OF ICODE=2 AND 3
164  C-- STEP IS STEP SIZE FOR FIELD LINE TRACING  C-- STEP IS STEP SIZE FOR FIELD LINE TRACING
# Line 210  C-- STEQ IS STEP SIZE FOR INTEGRATION Line 166  C-- STEQ IS STEP SIZE FOR INTEGRATION
166  C  C
167        DATA RMIN,RMAX    /0.05,1.01/        DATA RMIN,RMAX    /0.05,1.01/
168        DATA STEP,STEQ    /0.20,0.03/        DATA STEP,STEQ    /0.20,0.03/
169          BEQU=1.E10        BEQU=1.E10
170          FLS = FL
171  C*****ENTRY POINT  SHELLG  TO BE USED WITH GEODETIC CO-ORDINATES  C*****ENTRY POINT  SHELLG  TO BE USED WITH GEODETIC CO-ORDINATES
172        RLAT=GLAT*UMR        RLAT=GLAT*UMR
173        CT=SIN(RLAT)                                                      CT=SIN(RLAT)                                              
# Line 311  C*****INNER LOOP (FOR QUADRATURE)       Line 268  C*****INNER LOOP (FOR QUADRATURE)      
268        HLI=0.5*(((C3*T+C2)*T+C1)*T+C0)                                    HLI=0.5*(((C3*T+C2)*T+C1)*T+C0)                            
269        ZQ=Z*Z        ZQ=Z*Z
270        R=HLI+SQRT(HLI*HLI+ZQ)        R=HLI+SQRT(HLI*HLI+ZQ)
271          IF(R.NE.R)THEN
272             FL = FLS
273             RETURN
274          ENDIF
275        IF(R.LE.RMIN)GOTO30                                      IF(R.LE.RMIN)GOTO30                              
276        RQ=R*R        RQ=R*R
277        FF=SQRT(1.+3.*ZQ/RQ)                                      FF=SQRT(1.+3.*ZQ/RQ)                              
# Line 356  C Line 317  C
317  C-- Correct dipole moment is used here. D. Bilitza, Nov 87.  C-- Correct dipole moment is used here. D. Bilitza, Nov 87.
318  C  C
319        DIMOB0=DIMO/B0        DIMOB0=DIMO/B0
320        arg1=dlog(FI)        arg1=alog(FI)
321        arg2=dlog(DIMOB0)        arg2=alog(DIMOB0)
322  c    arg = FI*FI*FI/DIMOB0  c    arg = FI*FI*FI/DIMOB0
323  c    if(abs(arg).gt.88.0) arg=88.0  c    if(abs(arg).gt.88.0) arg=88.0
324        XX=3*arg1-arg2        XX=3*arg1-arg2
# Line 385  c  771 GG=3.33338E-1*XX+3.0062102E-1     Line 346  c  771 GG=3.33338E-1*XX+3.0062102E-1    
346       1E-3)*XX+1.2038224E-1)*XX-1.8461796E-1)*XX+2.0007187E0                   1E-3)*XX+1.2038224E-1)*XX-1.8461796E-1)*XX+2.0007187E0            
347        GOTO777                                                                  GOTO777                                                          
348    776 GG=XX-3.0460681E0                                                    776 GG=XX-3.0460681E0                                                
349    777 FL=EXP(dLOG((1.+EXP(GG))*DIMOB0)/3.0)    777 FL=EXP(ALOG((1.+EXP(GG))*DIMOB0)/3.0)
350        RETURN                                                                    RETURN                                                            
351  C*****APPROXIMATION FOR HIGH VALUES OF L.                                C*****APPROXIMATION FOR HIGH VALUES OF L.                              
352  30    ICODE=3                                                            30    ICODE=3                                                          
# Line 396  C*****APPROXIMATION FOR HIGH VALUES OF L Line 357  C*****APPROXIMATION FOR HIGH VALUES OF L
357  C  C
358  C  C
359        SUBROUTINE STOER(P,BQ,R)                                                  SUBROUTINE STOER(P,BQ,R)                                          
       IMPLICIT REAL(8)(A-H)  
       IMPLICIT REAL(8)(O-Z)  
   
360  C*******************************************************************  C*******************************************************************
361  C* SUBROUTINE USED FOR FIELD LINE TRACING IN SHELLG                *  C* SUBROUTINE USED FOR FIELD LINE TRACING IN SHELLG                *
362  C* CALLS ENTRY POINT FELDI IN GEOMAGNETIC FIELD SUBROUTINE FELDG   *  C* CALLS ENTRY POINT FELDI IN GEOMAGNETIC FIELD SUBROUTINE FELDG   *
363  C*******************************************************************  C*******************************************************************
       REAL(8) P,ZM,FLI,WR,XM,R,YM,XI,DR  
364        DIMENSION         P(7),U(3,3)        DIMENSION         P(7),U(3,3)
365        COMMON            XI(3),H(196)        COMMON            XI(3),H(196)
366  C*****XM,YM,ZM  ARE GEOMAGNETIC CARTESIAN INVERSE CO-ORDINATES            C*****XM,YM,ZM  ARE GEOMAGNETIC CARTESIAN INVERSE CO-ORDINATES          
# Line 445  C*****FORM SLOWLY VARYING EXPRESSIONS   Line 402  C*****FORM SLOWLY VARYING EXPRESSIONS  
402  C  C
403  C  C
404        SUBROUTINE FELDG(GLAT,GLON,ALT,BNORTH,BEAST,BDOWN,BABS)                  SUBROUTINE FELDG(GLAT,GLON,ALT,BNORTH,BEAST,BDOWN,BABS)          
       IMPLICIT REAL(8)(A-H)  
       IMPLICIT REAL(8)(O-Z)  
405  C-------------------------------------------------------------------  C-------------------------------------------------------------------
406  C CALCULATES EARTH MAGNETIC FIELD FROM SPHERICAL HARMONICS MODEL  C CALCULATES EARTH MAGNETIC FIELD FROM SPHERICAL HARMONICS MODEL
407  C REF: G. KLUGE, EUROPEAN SPACE OPERATIONS CENTRE, INTERNAL NOTE 61,  C REF: G. KLUGE, EUROPEAN SPACE OPERATIONS CENTRE, INTERNAL NOTE 61,
# Line 489  C                 TO THE LOCAL GEODETIC Line 444  C                 TO THE LOCAL GEODETIC
444  C                 POINTING IN THE TANGENTIAL PLANE TO THE NORTH, EAST  C                 POINTING IN THE TANGENTIAL PLANE TO THE NORTH, EAST
445  C                 AND DOWNWARD.    C                 AND DOWNWARD.  
446  C-----------------------------------------------------------------------  C-----------------------------------------------------------------------
       REAL(8) G,H,X,Z,F,S,T,XI,Y,XXX,BXXX,BYYY,BZZZ,B  
       REAL(8) YYY,ZZZ,BABS,BEAST,BRHO,BNORTH,BDOWN,ST,CT,CP,SP  
       REAL(8) ERA, AQUAD, BQUAD,ALT,RHO,RQ,D  
447        DIMENSION         V(3),B(3),G(196)        DIMENSION         V(3),B(3),G(196)
448        CHARACTER*258      NAME        CHARACTER*258      NAME
449        INTEGER NMAX        INTEGER NMAX
450        REAL TIME        REAL TIME
451        COMMON            XI(3),H(196)        COMMON            XI(3),H(196)
         
452        COMMON/MODEL/     G,NMAX,TIME,NAME        COMMON/MODEL/     G,NMAX,TIME,NAME
453        SAVE/MODEL/        SAVE/MODEL/
454        COMMON/GENER/     ERA,AQUAD,BQUAD,UMR        COMMON/GENER/     UMR,ERA,AQUAD,BQUAD
455        SAVE/GENER/        SAVE/GENER/
456  C  C
457  C-- IS RECORDS ENTRY POINT  C-- IS RECORDS ENTRY POINT
# Line 583  c      print *,' I ',I Line 534  c      print *,' I ',I
534  C  C
535  C  C
536        SUBROUTINE FELDCOF(YEAR,DIMO)        SUBROUTINE FELDCOF(YEAR,DIMO)
       IMPLICIT REAL(8)(A-H)  
       IMPLICIT REAL(8)(O-Z)  
537  C------------------------------------------------------------------------  C------------------------------------------------------------------------
538  C     DETERMINES COEFFICIENTS AND DIPOL MOMENT FROM IGRF MODELS  C     DETERMINES COEFFICIENTS AND DIPOL MOMENT FROM IGRF MODELS
539  C      C    
# Line 599  C     ### updated to IGRF-2005 version - Line 548  C     ### updated to IGRF-2005 version -
548  C-----------------------------------------------------------------------  C-----------------------------------------------------------------------
549        CHARACTER*258    FIL1, FIL2                  CHARACTER*258    FIL1, FIL2          
550        CHARACTER*258    FILMOD        CHARACTER*258    FILMOD
551  C     ### FILMOD, DTEMOD arrays +1        DIMENSION       GH1(196),GH2(196),GHA(196),FILMOD(2)
 c     DIMENSION       GH1(144),GH2(120),GHA(144),FILMOD(14),DTEMOD(14)  
       REAL(8) GH1, GH2, GHA  
       DIMENSION       GH1(196),GH2(196),GHA(196),FILMOD(3),DTEMOD(3)  
552        DOUBLE PRECISION X,F0,F        DOUBLE PRECISION X,F0,F
553        DOUBLE PRECISION DIMO        INTEGER L1,L2,I1
       INTEGER L1,L2,L3  
554        INTEGER NMAX        INTEGER NMAX
       REAL YEAR  
555        REAL TIME        REAL TIME
556        CHARACTER *258 P1,P2,P3        CHARACTER *258 P1,P2
557        REAL(8) AQUAD,BQUAD,ERAD        COMMON/PPATH/ I1,L1,L2,P1,P2
       COMMON/PPATH/ L1,L2,L3,P1, P2, P3  
558        SAVE/PPATH/        SAVE/PPATH/
559        COMMON/MODEL/   GH1,NMAX,TIME,FIL1        COMMON/MODEL/   GH1,NMAX,TIME,FIL1
560        SAVE/MODEL/        SAVE/MODEL/
561        COMMON/GENER/   ERAD,AQUAD,BQUAD,UMR        COMMON/GENER/   UMR,ERAD,AQUAD,BQUAD
562        SAVE/GENER/        SAVE/GENER/
 C     ### updated to 2005  
 C     CHARACTER COEFPATH*80, COEF1*80, COEF2*80, COEF3*80  
         
 c     COEFPATH  = 'OrbitalInfo/src/'  
 c     COEF1 = 'dgrf00.dat'  
 c     COEF2 = 'igrf05.dat'  
 c     COEF3 = 'igrf05s.dat'  
 c     COEF1 = COEFPATH(1:16)//COEF1  
 c     COEF2 = COEFPATH(1:16)//COEF2  
 c     COEF3 = COEFPATH(1:16)//COEF3  
 c     FILMOD(1) = COEF1  
 c     FILMOD(2) = COEF2  
 c     FILMOD(3) = COEF3  
563  c      print *, "qui"  c      print *, "qui"
564        FILMOD(1) = P1(1:L1)        FILMOD(1) = P1(1:L1)
565        FILMOD(2) = P2(1:L2)        FILMOD(2) = P2(1:L2)
       FILMOD(3) = P3(1:L3)  
566  c      print *, "qua"  c      print *, "qua"
 c     FILMOD(1) = 'OrbitalInfo/src/dgrf00.dat'  
 c     FILMOD(2) = 'OrbitalInfo/src/igrf05.dat'  
 c     FILMOD(3) = 'OrbitalInfo/src/igrf05s.dat'  
 c      WRITE(*,*) FILMOD(1)  
 c      WRITE(*,*) FILMOD(2)  
 c      WRITE(*,*) FILMOD(3)  
 c      DATA   FILMOD / 'dgrf00.dat', 'igrf05.dat', 'igrf05s.dat'/  
       DATA   DTEMOD / 2005., 2010., 2015./  
 c      
 c     DATA            FILMOD /'dgrf45.dat', 'dgrf50.dat',              
 c     1                  'dgrf55.dat', 'dgrf60.dat', 'dgrf65.dat',        
 c     2                  'dgrf70.dat', 'dgrf75.dat', 'dgrf80.dat',        
 c     3                  'dgrf85.dat', 'dgrf90.dat', 'dgrf95.dat',  
 c     4                  'dgrf00.dat','igrf05.dat','igrf05s.dat'/  
 c     DATA   DTEMOD / 1945., 1950., 1955., 1960., 1965., 1970.,  
 c     1       1975., 1980., 1985., 1990., 1995., 2000.,2005.,2010./        
 C      
 C     ### numye = numye + 1 ; is number of years represented by IGRF  
 C      
 c     NUMYE=13  
       NUMYE=2  
 c      print *, "quo"  
         
567  C      C    
568  C     IS=0 FOR SCHMIDT NORMALIZATION   IS=1 GAUSS NORMALIZATION  C     IS=0 FOR SCHMIDT NORMALIZATION   IS=1 GAUSS NORMALIZATION
569  C     IU  IS INPUT UNIT NUMBER FOR IGRF COEFFICIENT SETS  C     IU  IS INPUT UNIT NUMBER FOR IGRF COEFFICIENT SETS
# Line 667  C     Line 573  C    
573  C--   DETERMINE IGRF-YEARS FOR INPUT-YEAR  C--   DETERMINE IGRF-YEARS FOR INPUT-YEAR
574        TIME = YEAR        TIME = YEAR
575        IYEA = INT(YEAR/5.)*5        IYEA = INT(YEAR/5.)*5
576  c     L = (IYEA - 1945)/5 + 1        L = IYEA + 5
577        L = (IYEA - 2000)/5 + 1  C
578        IF(L.LT.1) L=1        DTE1 = REAL(IYEA)  
579        IF(L.GT.NUMYE) L=NUMYE                FIL1 = FILMOD(1)  
580        DTE1 = DTEMOD(L)          DTE2 = REAL(L)
581        FIL1 = FILMOD(L)          FIL2 = FILMOD(2)
582        DTE2 = DTEMOD(L+1)  c      print *,'IYEA ',IYEA,' L ',L
       FIL2 = FILMOD(L+1)  
583  c      WRITE(*,*) FIL1  c      WRITE(*,*) FIL1
584  c      WRITE(*,*) FIL2  c      WRITE(*,*) FIL2
585  c      print *, "que"  c      print *, "que"
# Line 686  c      print *, "quessss" Line 591  c      print *, "quessss"
591        IF (IER .NE. 0) STOP                            IF (IER .NE. 0) STOP                    
592  c      print *, "quj"  c      print *, "quj"
593  C--   DETERMINE IGRF COEFFICIENTS FOR YEAR  C--   DETERMINE IGRF COEFFICIENTS FOR YEAR
594        IF (L .LE. NUMYE-1) THEN                                IF (I1.EQ.0) THEN      
595           CALL INTERSHC (YEAR, DTE1, NMAX1, GH1, DTE2,           CALL INTERSHC (YEAR, DTE1, NMAX1, GH1, DTE2,
596       1        NMAX2, GH2, NMAX, GHA)                               1        NMAX2, GH2, NMAX, GHA)                        
597        ELSE                      ELSE              
# Line 700  C--   DETERMINE MAGNETIC DIPOL MOMENT AN Line 605  C--   DETERMINE MAGNETIC DIPOL MOMENT AN
605           F = GHA(J) * 1.D-5           F = GHA(J) * 1.D-5
606           F0 = F0 + F * F           F0 = F0 + F * F
607   1234 CONTINUE   1234 CONTINUE
608        DIMO = DSQRT(F0)        DIMO = REAL(DSQRT(F0))
609                
610        GH1(1) =  0.0        GH1(1) =  0.0
611        I=2                  I=2          
# Line 716  c      print *, "quq" Line 621  c      print *, "quq"
621           IF(IS.EQ.0) F0 = F0 * (2.D0 * X - 1.D0) / X           IF(IS.EQ.0) F0 = F0 * (2.D0 * X - 1.D0) / X
622           F = F0 * 0.5D0                                               F = F0 * 0.5D0                                    
623           IF(IS.EQ.0) F = F * SQRT2           IF(IS.EQ.0) F = F * SQRT2
624           GH1(I) = GHA(I-1) * F0           GH1(I) = GHA(I-1) * REAL(F0)
625           I = I+1                                                   I = I+1                                        
626           DO 9 M=1,N                                               DO 9 M=1,N                                    
627              F = F * (X + M) / (X - M + 1.D0)                              F = F * (X + M) / (X - M + 1.D0)                
628              IF(IS.EQ.0) F = F * DSQRT((X - M + 1.D0) / (X + M))              IF(IS.EQ.0) F = F * DSQRT((X - M + 1.D0) / (X + M))
629              GH1(I) = GHA(I-1) * F              GH1(I) = GHA(I-1) * REAL(F)
630              GH1(I+1) = GHA(I) * F              GH1(I+1) = GHA(I) * REAL(F)
631              I=I+2              I=I+2
632   9       CONTINUE                                             9       CONTINUE                                          
633        RETURN        RETURN
# Line 730  c      print *, "quq" Line 635  c      print *, "quq"
635  C      C    
636  C      C    
637        SUBROUTINE GETSHC (IU, FSPEC, NMAX, ERAD, GH, IER)                  SUBROUTINE GETSHC (IU, FSPEC, NMAX, ERAD, GH, IER)          
638        IMPLICIT REAL(8)(A-H)                                                                                  
       IMPLICIT REAL(8)(O-Z)  
639  C ===============================================================                C ===============================================================              
640  C                                                                                C                                                                              
641  C     Version 1.01                                                  C     Version 1.01                                                
# Line 760  C     Line 664  C    
664  C     ===============================================================                C     ===============================================================              
665                
666        CHARACTER  FSPEC*(*), FOUT*258        CHARACTER  FSPEC*(*), FOUT*258
       REAL(8) GH,ERAD  
667        DIMENSION       GH(*)                                                DIMENSION       GH(*)                                        
668  C     ---------------------------------------------------------------                C     ---------------------------------------------------------------              
669  C     Open coefficient file. Read past first header record.          C     Open coefficient file. Read past first header record.        
# Line 824  C Line 727  C
727  C  C
728          SUBROUTINE INTERSHC (DATE, DTE1, NMAX1, GH1, DTE2,                    SUBROUTINE INTERSHC (DATE, DTE1, NMAX1, GH1, DTE2,          
729       1                        NMAX2, GH2, NMAX, GH)                         1                        NMAX2, GH2, NMAX, GH)                  
730          IMPLICIT REAL(8)(A-H)                                                                                  
         IMPLICIT REAL(8)(O-Z)  
         REAL DATE  
731  C ===============================================================                C ===============================================================              
732  C                                                                                C                                                                              
733  C       Version 1.01                                                  C       Version 1.01                                                
# Line 854  C       USGS, MS 964, Box 25046 Federal Line 755  C       USGS, MS 964, Box 25046 Federal
755  C                                                                                C                                                                              
756  C ===============================================================                C ===============================================================              
757                                                                                                                                                                    
         REAL(8) GH1, GH2, GH  
758          DIMENSION       GH1(*), GH2(*), GH(*)                                  DIMENSION       GH1(*), GH2(*), GH(*)                        
759                                                                                                                                                                    
760  C ---------------------------------------------------------------                C ---------------------------------------------------------------              
# Line 894  C Line 794  C
794  C  C
795          SUBROUTINE EXTRASHC (DATE, DTE1, NMAX1, GH1, NMAX2,                    SUBROUTINE EXTRASHC (DATE, DTE1, NMAX1, GH1, NMAX2,          
796       1                        GH2, NMAX, GH)                                 1                        GH2, NMAX, GH)                          
         IMPLICIT REAL(8)(A-H)  
         IMPLICIT REAL(8)(O-Z)  
         REAL DATE  
797                                                                                                                                                                    
798  C ===============================================================                C ===============================================================              
799  C                                                                                C                                                                              
# Line 925  C       USGS, MS 964, Box 25046 Federal Line 822  C       USGS, MS 964, Box 25046 Federal
822  C                                                                                C                                                                              
823  C ===============================================================                C ===============================================================              
824                                                                                                                                                                    
         REAL(8) GH1, GH2, GH  
825          DIMENSION       GH1(*), GH2(*), GH(*)                                    DIMENSION       GH1(*), GH2(*), GH(*)                          
826                                                                                                                                                                    
827  C ---------------------------------------------------------------                C ---------------------------------------------------------------              
# Line 963  C -------------------------------------- Line 859  C --------------------------------------
859          END                                                                      END                                                            
860  C  C
861  C  C
862          SUBROUTINE INITIZE(TP1,TL1,TP2,TL2,TP3,TL3)          SUBROUTINE INITIZE(ISSEC,TP1,TL1,TP2,TL2)
         IMPLICIT REAL(8)(A-H)  
         IMPLICIT REAL(8)(O-Z)  
863  C----------------------------------------------------------------  C----------------------------------------------------------------
864  C Initializes the parameters in COMMON/GENER/  C Initializes the parameters in COMMON/GENER/
865  C  C
# Line 980  C Line 874  C
874  C ERA, EREQU and ERPOL as recommended by the INTERNATIONAL  C ERA, EREQU and ERPOL as recommended by the INTERNATIONAL
875  C ASTRONOMICAL UNION .  C ASTRONOMICAL UNION .
876  C-----------------------------------------------------------------  C-----------------------------------------------------------------
877          INTEGER TL1,TL2,TL3          INTEGER TL1,TL2,ISSEC
878          CHARACTER (len=258) TP1,TP2,TP3          CHARACTER (len=*) :: TP1,TP2
879          INTEGER L1,L2,L3          INTEGER L1,L2
880          CHARACTER *258 P1,P2,P3          CHARACTER *258 P1,P2
881          REAL(8) AQUAD,BQUAD,ERA          COMMON/PPATH/ I1,L1,L2,P1,P2
   
         COMMON/PPATH/ L1,L2,L3,P1, P2, P3  
882          SAVE/PPATH/          SAVE/PPATH/
883    
884          COMMON/GENER/ERA,AQUAD,BQUAD,UMR          COMMON/GENER/UMR,ERA,AQUAD,BQUAD
885          SAVE/GENER/          SAVE/GENER/
886    
887            I1 = ISSEC
888          L1 = TL1          L1 = TL1
889          L2 = TL2          L2 = TL2
890          L3 = TL3  
891          P1 = TP1(1:L1)          P1 = TP1(1:L1)
892          P2 = TP2(1:L2)          P2 = TP2(1:L2)
         P3 = TP3(1:L3)  
893    
894          ERA=6371.2          ERA=6371.2
895          EREQU=6378.16          EREQU=6378.16
Legend:
Removed from v.1.8  
changed lines
  Added in v.1.12
  ViewVC Help
Powered by ViewVC 1.1.23