/[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.11 by mocchiut, Fri Oct 31 14:02:53 2014 UTC
# Line 55  C*************************************** Line 55  C***************************************
55  C  C
56  C  C
57        SUBROUTINE FINDB0(STPS,BDEL,VALUE,BEQU,RR0)        SUBROUTINE FINDB0(STPS,BDEL,VALUE,BEQU,RR0)
       IMPLICIT REAL(8)(A-H)  
       IMPLICIT REAL(8)(O-Z)  
58  C--------------------------------------------------------------------  C--------------------------------------------------------------------
59  C FINDS SMALLEST MAGNETIC FIELD STRENGTH ON FIELD LINE  C FINDS SMALLEST MAGNETIC FIELD STRENGTH ON FIELD LINE
60  C  C
# Line 72  C          BEQU   MAGNETIC FIELD STRENGT Line 70  C          BEQU   MAGNETIC FIELD STRENGT
70  C          RR0    EQUATORIAL RADIUS NORMALIZED TO EARTH RADIUS  C          RR0    EQUATORIAL RADIUS NORMALIZED TO EARTH RADIUS
71  C          BDEL   FINAL ACHIEVED ACCURACY  C          BDEL   FINAL ACHIEVED ACCURACY
72  C--------------------------------------------------------------------  C--------------------------------------------------------------------
       REAL(8) P  
73        DIMENSION         P(8,4),SP(3)        DIMENSION         P(8,4),SP(3)
74        LOGICAL           VALUE        LOGICAL           VALUE
75        COMMON/FIDB0/     SP        COMMON/FIDB0/     SP
# Line 157  C        DO 1111 I=1,8 Line 154  C        DO 1111 I=1,8
154  C  C
155  C  C
156        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)  
157  C--------------------------------------------------------------------  C--------------------------------------------------------------------
158  C CALCULATES L-VALUE FOR SPECIFIED GEODAETIC COORDINATES, ALTITUDE  C CALCULATES L-VALUE FOR SPECIFIED GEODAETIC COORDINATES, ALTITUDE
159  C AND GEMAGNETIC FIELD MODEL.  C AND GEMAGNETIC FIELD MODEL.
# Line 195  C                          WHICH ACCURAT Line 190  C                          WHICH ACCURAT
190  C                          APPROXIMATION IS USED.  C                          APPROXIMATION IS USED.
191  C          B0           MAGNETIC FIELD STRENGTH IN GAUSS  C          B0           MAGNETIC FIELD STRENGTH IN GAUSS
192  C-----------------------------------------------------------------------  C-----------------------------------------------------------------------
       REAL(8) AQUAD,BQUAD,ERA  
       REAL(8) CT,ST,D,ALT,X,RQ,P,U,STEP  
193        DIMENSION         V(3),U(3,3),P(8,100),SP(3)        DIMENSION         V(3),U(3,3),P(8,100),SP(3)
194        COMMON            X(3),H(196)        COMMON            X(3),H(196)
195        COMMON/FIDB0/     SP        COMMON/FIDB0/     SP
196        SAVE /FIDB0/        SAVE /FIDB0/
197        COMMON/GENER/     ERA,AQUAD,BQUAD,UMR        COMMON/GENER/     UMR,ERA,AQUAD,BQUAD
198        SAVE /GENER/        SAVE /GENER/
199          REAL FLS
200  C  C
201  C-- RMIN, RMAX ARE BOUNDARIES FOR IDENTIFICATION OF ICODE=2 AND 3  C-- RMIN, RMAX ARE BOUNDARIES FOR IDENTIFICATION OF ICODE=2 AND 3
202  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 204  C-- STEQ IS STEP SIZE FOR INTEGRATION
204  C  C
205        DATA RMIN,RMAX    /0.05,1.01/        DATA RMIN,RMAX    /0.05,1.01/
206        DATA STEP,STEQ    /0.20,0.03/        DATA STEP,STEQ    /0.20,0.03/
207          BEQU=1.E10        BEQU=1.E10
208          FLS = FL
209  C*****ENTRY POINT  SHELLG  TO BE USED WITH GEODETIC CO-ORDINATES  C*****ENTRY POINT  SHELLG  TO BE USED WITH GEODETIC CO-ORDINATES
210        RLAT=GLAT*UMR        RLAT=GLAT*UMR
211        CT=SIN(RLAT)                                                      CT=SIN(RLAT)                                              
# Line 311  C*****INNER LOOP (FOR QUADRATURE)       Line 306  C*****INNER LOOP (FOR QUADRATURE)      
306        HLI=0.5*(((C3*T+C2)*T+C1)*T+C0)                                    HLI=0.5*(((C3*T+C2)*T+C1)*T+C0)                            
307        ZQ=Z*Z        ZQ=Z*Z
308        R=HLI+SQRT(HLI*HLI+ZQ)        R=HLI+SQRT(HLI*HLI+ZQ)
309          IF(R.NE.R)THEN
310             FL = FLS
311             RETURN
312          ENDIF
313        IF(R.LE.RMIN)GOTO30                                      IF(R.LE.RMIN)GOTO30                              
314        RQ=R*R        RQ=R*R
315        FF=SQRT(1.+3.*ZQ/RQ)                                      FF=SQRT(1.+3.*ZQ/RQ)                              
# Line 356  C Line 355  C
355  C-- Correct dipole moment is used here. D. Bilitza, Nov 87.  C-- Correct dipole moment is used here. D. Bilitza, Nov 87.
356  C  C
357        DIMOB0=DIMO/B0        DIMOB0=DIMO/B0
358        arg1=dlog(FI)        arg1=alog(FI)
359        arg2=dlog(DIMOB0)        arg2=alog(DIMOB0)
360  c    arg = FI*FI*FI/DIMOB0  c    arg = FI*FI*FI/DIMOB0
361  c    if(abs(arg).gt.88.0) arg=88.0  c    if(abs(arg).gt.88.0) arg=88.0
362        XX=3*arg1-arg2        XX=3*arg1-arg2
# Line 385  c  771 GG=3.33338E-1*XX+3.0062102E-1     Line 384  c  771 GG=3.33338E-1*XX+3.0062102E-1    
384       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            
385        GOTO777                                                                  GOTO777                                                          
386    776 GG=XX-3.0460681E0                                                    776 GG=XX-3.0460681E0                                                
387    777 FL=EXP(dLOG((1.+EXP(GG))*DIMOB0)/3.0)    777 FL=EXP(ALOG((1.+EXP(GG))*DIMOB0)/3.0)
388        RETURN                                                                    RETURN                                                            
389  C*****APPROXIMATION FOR HIGH VALUES OF L.                                C*****APPROXIMATION FOR HIGH VALUES OF L.                              
390  30    ICODE=3                                                            30    ICODE=3                                                          
# Line 396  C*****APPROXIMATION FOR HIGH VALUES OF L Line 395  C*****APPROXIMATION FOR HIGH VALUES OF L
395  C  C
396  C  C
397        SUBROUTINE STOER(P,BQ,R)                                                  SUBROUTINE STOER(P,BQ,R)                                          
       IMPLICIT REAL(8)(A-H)  
       IMPLICIT REAL(8)(O-Z)  
   
398  C*******************************************************************  C*******************************************************************
399  C* SUBROUTINE USED FOR FIELD LINE TRACING IN SHELLG                *  C* SUBROUTINE USED FOR FIELD LINE TRACING IN SHELLG                *
400  C* CALLS ENTRY POINT FELDI IN GEOMAGNETIC FIELD SUBROUTINE FELDG   *  C* CALLS ENTRY POINT FELDI IN GEOMAGNETIC FIELD SUBROUTINE FELDG   *
401  C*******************************************************************  C*******************************************************************
       REAL(8) P,ZM,FLI,WR,XM,R,YM,XI,DR  
402        DIMENSION         P(7),U(3,3)        DIMENSION         P(7),U(3,3)
403        COMMON            XI(3),H(196)        COMMON            XI(3),H(196)
404  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 440  C*****FORM SLOWLY VARYING EXPRESSIONS  
440  C  C
441  C  C
442        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)  
443  C-------------------------------------------------------------------  C-------------------------------------------------------------------
444  C CALCULATES EARTH MAGNETIC FIELD FROM SPHERICAL HARMONICS MODEL  C CALCULATES EARTH MAGNETIC FIELD FROM SPHERICAL HARMONICS MODEL
445  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 482  C                 TO THE LOCAL GEODETIC
482  C                 POINTING IN THE TANGENTIAL PLANE TO THE NORTH, EAST  C                 POINTING IN THE TANGENTIAL PLANE TO THE NORTH, EAST
483  C                 AND DOWNWARD.    C                 AND DOWNWARD.  
484  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  
485        DIMENSION         V(3),B(3),G(196)        DIMENSION         V(3),B(3),G(196)
486        CHARACTER*258      NAME        CHARACTER*258      NAME
487        INTEGER NMAX        INTEGER NMAX
488        REAL TIME        REAL TIME
489        COMMON            XI(3),H(196)        COMMON            XI(3),H(196)
         
490        COMMON/MODEL/     G,NMAX,TIME,NAME        COMMON/MODEL/     G,NMAX,TIME,NAME
491        SAVE/MODEL/        SAVE/MODEL/
492        COMMON/GENER/     ERA,AQUAD,BQUAD,UMR        COMMON/GENER/     UMR,ERA,AQUAD,BQUAD
493        SAVE/GENER/        SAVE/GENER/
494  C  C
495  C-- IS RECORDS ENTRY POINT  C-- IS RECORDS ENTRY POINT
# Line 583  c      print *,' I ',I Line 572  c      print *,' I ',I
572  C  C
573  C  C
574        SUBROUTINE FELDCOF(YEAR,DIMO)        SUBROUTINE FELDCOF(YEAR,DIMO)
       IMPLICIT REAL(8)(A-H)  
       IMPLICIT REAL(8)(O-Z)  
575  C------------------------------------------------------------------------  C------------------------------------------------------------------------
576  C     DETERMINES COEFFICIENTS AND DIPOL MOMENT FROM IGRF MODELS  C     DETERMINES COEFFICIENTS AND DIPOL MOMENT FROM IGRF MODELS
577  C      C    
# Line 601  C--------------------------------------- Line 588  C---------------------------------------
588        CHARACTER*258    FILMOD        CHARACTER*258    FILMOD
589  C     ### FILMOD, DTEMOD arrays +1  C     ### FILMOD, DTEMOD arrays +1
590  c     DIMENSION       GH1(144),GH2(120),GHA(144),FILMOD(14),DTEMOD(14)  c     DIMENSION       GH1(144),GH2(120),GHA(144),FILMOD(14),DTEMOD(14)
       REAL(8) GH1, GH2, GHA  
591        DIMENSION       GH1(196),GH2(196),GHA(196),FILMOD(3),DTEMOD(3)        DIMENSION       GH1(196),GH2(196),GHA(196),FILMOD(3),DTEMOD(3)
592        DOUBLE PRECISION X,F0,F        DOUBLE PRECISION X,F0,F
       DOUBLE PRECISION DIMO  
593        INTEGER L1,L2,L3        INTEGER L1,L2,L3
594        INTEGER NMAX        INTEGER NMAX
       REAL YEAR  
595        REAL TIME        REAL TIME
596        CHARACTER *258 P1,P2,P3        CHARACTER *258 P1,P2,P3
       REAL(8) AQUAD,BQUAD,ERAD  
597        COMMON/PPATH/ L1,L2,L3,P1, P2, P3        COMMON/PPATH/ L1,L2,L3,P1, P2, P3
598        SAVE/PPATH/        SAVE/PPATH/
599        COMMON/MODEL/   GH1,NMAX,TIME,FIL1        COMMON/MODEL/   GH1,NMAX,TIME,FIL1
600        SAVE/MODEL/        SAVE/MODEL/
601        COMMON/GENER/   ERAD,AQUAD,BQUAD,UMR        COMMON/GENER/   UMR,ERAD,AQUAD,BQUAD
602        SAVE/GENER/        SAVE/GENER/
603  C     ### updated to 2005  C     ### updated to 2005
604  C     CHARACTER COEFPATH*80, COEF1*80, COEF2*80, COEF3*80  C     CHARACTER COEFPATH*80, COEF1*80, COEF2*80, COEF3*80
# Line 700  C--   DETERMINE MAGNETIC DIPOL MOMENT AN Line 683  C--   DETERMINE MAGNETIC DIPOL MOMENT AN
683           F = GHA(J) * 1.D-5           F = GHA(J) * 1.D-5
684           F0 = F0 + F * F           F0 = F0 + F * F
685   1234 CONTINUE   1234 CONTINUE
686        DIMO = DSQRT(F0)        DIMO = REAL(DSQRT(F0))
687                
688        GH1(1) =  0.0        GH1(1) =  0.0
689        I=2                  I=2          
# Line 716  c      print *, "quq" Line 699  c      print *, "quq"
699           IF(IS.EQ.0) F0 = F0 * (2.D0 * X - 1.D0) / X           IF(IS.EQ.0) F0 = F0 * (2.D0 * X - 1.D0) / X
700           F = F0 * 0.5D0                                               F = F0 * 0.5D0                                    
701           IF(IS.EQ.0) F = F * SQRT2           IF(IS.EQ.0) F = F * SQRT2
702           GH1(I) = GHA(I-1) * F0           GH1(I) = GHA(I-1) * REAL(F0)
703           I = I+1                                                   I = I+1                                        
704           DO 9 M=1,N                                               DO 9 M=1,N                                    
705              F = F * (X + M) / (X - M + 1.D0)                              F = F * (X + M) / (X - M + 1.D0)                
706              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))
707              GH1(I) = GHA(I-1) * F              GH1(I) = GHA(I-1) * REAL(F)
708              GH1(I+1) = GHA(I) * F              GH1(I+1) = GHA(I) * REAL(F)
709              I=I+2              I=I+2
710   9       CONTINUE                                             9       CONTINUE                                          
711        RETURN        RETURN
# Line 730  c      print *, "quq" Line 713  c      print *, "quq"
713  C      C    
714  C      C    
715        SUBROUTINE GETSHC (IU, FSPEC, NMAX, ERAD, GH, IER)                  SUBROUTINE GETSHC (IU, FSPEC, NMAX, ERAD, GH, IER)          
716        IMPLICIT REAL(8)(A-H)                                                                                  
       IMPLICIT REAL(8)(O-Z)  
717  C ===============================================================                C ===============================================================              
718  C                                                                                C                                                                              
719  C     Version 1.01                                                  C     Version 1.01                                                
# Line 760  C     Line 742  C    
742  C     ===============================================================                C     ===============================================================              
743                
744        CHARACTER  FSPEC*(*), FOUT*258        CHARACTER  FSPEC*(*), FOUT*258
       REAL(8) GH,ERAD  
745        DIMENSION       GH(*)                                                DIMENSION       GH(*)                                        
746  C     ---------------------------------------------------------------                C     ---------------------------------------------------------------              
747  C     Open coefficient file. Read past first header record.          C     Open coefficient file. Read past first header record.        
# Line 824  C Line 805  C
805  C  C
806          SUBROUTINE INTERSHC (DATE, DTE1, NMAX1, GH1, DTE2,                    SUBROUTINE INTERSHC (DATE, DTE1, NMAX1, GH1, DTE2,          
807       1                        NMAX2, GH2, NMAX, GH)                         1                        NMAX2, GH2, NMAX, GH)                  
808          IMPLICIT REAL(8)(A-H)                                                                                  
         IMPLICIT REAL(8)(O-Z)  
         REAL DATE  
809  C ===============================================================                C ===============================================================              
810  C                                                                                C                                                                              
811  C       Version 1.01                                                  C       Version 1.01                                                
# Line 854  C       USGS, MS 964, Box 25046 Federal Line 833  C       USGS, MS 964, Box 25046 Federal
833  C                                                                                C                                                                              
834  C ===============================================================                C ===============================================================              
835                                                                                                                                                                    
         REAL(8) GH1, GH2, GH  
836          DIMENSION       GH1(*), GH2(*), GH(*)                                  DIMENSION       GH1(*), GH2(*), GH(*)                        
837                                                                                                                                                                    
838  C ---------------------------------------------------------------                C ---------------------------------------------------------------              
# Line 894  C Line 872  C
872  C  C
873          SUBROUTINE EXTRASHC (DATE, DTE1, NMAX1, GH1, NMAX2,                    SUBROUTINE EXTRASHC (DATE, DTE1, NMAX1, GH1, NMAX2,          
874       1                        GH2, NMAX, GH)                                 1                        GH2, NMAX, GH)                          
         IMPLICIT REAL(8)(A-H)  
         IMPLICIT REAL(8)(O-Z)  
         REAL DATE  
875                                                                                                                                                                    
876  C ===============================================================                C ===============================================================              
877  C                                                                                C                                                                              
# Line 925  C       USGS, MS 964, Box 25046 Federal Line 900  C       USGS, MS 964, Box 25046 Federal
900  C                                                                                C                                                                              
901  C ===============================================================                C ===============================================================              
902                                                                                                                                                                    
         REAL(8) GH1, GH2, GH  
903          DIMENSION       GH1(*), GH2(*), GH(*)                                    DIMENSION       GH1(*), GH2(*), GH(*)                          
904                                                                                                                                                                    
905  C ---------------------------------------------------------------                C ---------------------------------------------------------------              
# Line 964  C -------------------------------------- Line 938  C --------------------------------------
938  C  C
939  C  C
940          SUBROUTINE INITIZE(TP1,TL1,TP2,TL2,TP3,TL3)          SUBROUTINE INITIZE(TP1,TL1,TP2,TL2,TP3,TL3)
         IMPLICIT REAL(8)(A-H)  
         IMPLICIT REAL(8)(O-Z)  
941  C----------------------------------------------------------------  C----------------------------------------------------------------
942  C Initializes the parameters in COMMON/GENER/  C Initializes the parameters in COMMON/GENER/
943  C  C
# Line 981  C ERA, EREQU and ERPOL as recommended by Line 953  C ERA, EREQU and ERPOL as recommended by
953  C ASTRONOMICAL UNION .  C ASTRONOMICAL UNION .
954  C-----------------------------------------------------------------  C-----------------------------------------------------------------
955          INTEGER TL1,TL2,TL3          INTEGER TL1,TL2,TL3
956          CHARACTER (len=258) TP1,TP2,TP3          CHARACTER (len=*) :: TP1,TP2,TP3
957          INTEGER L1,L2,L3          INTEGER L1,L2,L3
958          CHARACTER *258 P1,P2,P3          CHARACTER *258 P1,P2,P3
         REAL(8) AQUAD,BQUAD,ERA  
   
959          COMMON/PPATH/ L1,L2,L3,P1, P2, P3          COMMON/PPATH/ L1,L2,L3,P1, P2, P3
960          SAVE/PPATH/          SAVE/PPATH/
961    
962          COMMON/GENER/ERA,AQUAD,BQUAD,UMR          COMMON/GENER/UMR,ERA,AQUAD,BQUAD
963          SAVE/GENER/          SAVE/GENER/
964    
965          L1 = TL1          L1 = TL1
Legend:
Removed from v.1.8  
changed lines
  Added in v.1.11
  ViewVC Help
Powered by ViewVC 1.1.23